Skip to content

Instantly share code, notes, and snippets.

@zeptometer

zeptometer/infix.lisp

Created March 26, 2011 08:19
Download ZIP

Revisions

  1. zeptometer revised this gist Mar 28, 2011. 1 changed file with 92 additions and 95 deletions.
    187 changes: 92 additions & 95 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -2,15 +2,12 @@
    (:use :cl)
    (:export #:add-operator
    #:add-infix-function
    #:initialize
    #:install-default-operators-and-infix-functions))

    (in-package :infix)

    (defconstant leastpriority 20)

    (defconstant default-operators
    '((1 ** expt right)
    '((1 ** expt :right)
    (2 *)
    (2 /)
    (2 % mod)
    @@ -29,9 +26,9 @@
    (9 \| logior)
    (10 && and)
    (11 || or)
    (12 = setf right)
    (12 += incf right)
    (12 -= decf right)))
    (12 = setf :right)
    (12 += incf :right)
    (12 -= decf :right)))

    (defconstant default-infix-functions
    '((sqrt 1)
    @@ -41,70 +38,68 @@
    (log 2)
    (loge 1 log)
    (log10 1 (lambda (x) (log x 10)))
    (+ 1)
    (- 1)
    (! 1 not)
    (~ 1 lognot)))

    (defclass infix-function ()
    ((type
    :initarg :type
    :accessor infix-function-type)
    (clname
    :initarg :clname
    :accessor infix-function-clname)
    (numarg
    :initarg :numarg
    :accessor infix-function-numarg)
    (priority
    :initarg :priority
    :initform 7
    :accessor infix-function-priority)
    (direction
    :initarg :direction
    :accessor infix-function-direction)))

    (defvar operators nil "演算子。優先順位の低い順にグループ分け。")
    (defvar operator-clfunction nil "演算子と関数の対応表")
    (defconstant leastpriority 20)

    (defvar arfunction nil "算術関数とその引数の一覧")
    (defvar arfunction-clfunction nil "算術関数とCL関数の対応表")
    (defvar *operators-priority* (make-hash-table :test #'equal) "優先順位毎の演算子")

    (defvar stack nil)
    (defvar *operators* (make-hash-table) "演算子と算術関数のデータ")

    (defun single (x)
    (and (consp x) (null (cdr x))))

    (defun operatorp (op)
    (some (lambda (x) (member op (cdr x))) operators))
    (multiple-value-bind (op* win) (gethash op *operators*)
    (and win (eq (infix-function-type op*) :operator))))

    (defun arfunctionp (ar)
    (cdr (assoc ar arfunction)))
    (defun ifunctionp (op)
    (multiple-value-bind (op* win) (gethash op *operators*)
    (and win (eq (infix-function-type op*) :ifunction))))

    (defun op-cl (op)
    "opに対応するCL関数を返す"
    (cdr (assoc op operator-clfunction)))
    (defun getnumarg (op)
    (infix-function-numarg (gethash op *operators*)))

    (defun ar-cl (ar)
    (cdr (assoc ar arfunction-clfunction)))
    (defun getclname (op)
    (infix-function-clname (gethash op *operators*)))

    (defun applyar (exp)
    (defun apply-ifunction (exp)
    "算術関数を普通のポーランド記法の形にする
    (applyar '(sqrt a + sin cos b))
    (apply-ifunction '(sqrt a + sin cos b))
    -> '((sqrt a) + (sin (cos b)))"
    (labels ((rec (exp loaded)
    (cond ((null exp)
    (reverse loaded))
    ((single exp)
    (rec nil (cons (car exp)loaded)))
    ((arfunctionp (car exp))
    (multiple-value-bind (exp* rest) (loadar exp)
    (rec (cons exp* rest) loaded)))
    ((and (not (arfunctionp (car exp)))
    (operatorp (cadr exp)))
    (rec (cddr exp) (list* (cadr exp) (car exp) loaded))))))
    (rec exp nil)))

    (defun loadar (exp)
    "applyar補助関数
    (loadar '(sqrt a + sin cos b))
    -> (sqrt a)
    (+ sin cos b)"
    (destructuring-bind (ar &rest rest) exp
    (push (list (ar-cl ar)) stack)
    (dotimes (i (arfunctionp ar))
    (if (arfunctionp (car rest))
    (multiple-value-bind (exp* rest*) (loadar rest)
    (push exp* (car stack))
    (setf rest rest*))
    (push (pop rest) (car stack))))
    (values (reverse (pop stack)) rest)))

    (defun devide-infix (exp ops)
    "(cdr ops)中の演算子でexpを分割する。(car ops)にある結合を用いる。
    (let ((stack nil))
    (dolist (i (nreverse exp))
    (if (ifunctionp i)
    (let ((polish))
    (push (getclname i) polish)
    (dotimes (j (getnumarg i))
    (push (pop stack) polish))
    (push (nreverse polish) stack))
    (push i stack)))
    stack))


    (defun devide-infix (exp ops direction)
    "ops中の演算子でexpを分割する。directionの結合を用いる。
    三つの値を返す。
    1: 演算子
    2: 演算子より前の式
    @@ -115,31 +110,32 @@
    -> -
    (1 + 2 * 3)
    (3)"
    (destructuring-bind (direction &rest ops*) ops
    (labels ((rec (exp ops* stack)
    (if (member (car exp) ops*)
    (ecase direction
    (left (values (car exp) (reverse (cdr exp)) stack))
    (right (values (car exp) (reverse stack) (cdr exp))))
    (rec (cdr exp) ops* (cons (car exp) stack)))))
    (ecase direction
    (left (rec (reverse exp) ops* nil))
    (right (rec exp ops* nil))))))
    (labels ((rec (exp ops* stack)
    (if (member (car exp) ops*)
    (ecase direction
    (:left (values (car exp) (reverse (cdr exp)) stack))
    (:right (values (car exp) (reverse stack) (cdr exp))))
    (rec (cdr exp) ops* (cons (car exp) stack)))))
    (ecase direction
    (:left (rec (reverse exp) ops nil))
    (:right (rec exp ops nil)))))

    (defun infix-polish (exp)
    "中間記法の式を普通のS式(ポーランド記法)に変換する。"
    (if (single exp)
    (car exp)
    (dolist (ops operators)
    (when (some (lambda (op) (member op exp)) (cdr ops))
    (multiple-value-bind (op bef af) (devide-infix exp ops)
    (return (list (op-cl op) (infix-polish bef) (infix-polish af))))))))
    (do ((priority 20 (- priority (ecase dir (:left 0) (:right 1))))
    (dir :left (ecase dir (:left :right) (:right :left))))
    ((zerop priority) nil)
    (let ((ops (gethash `(,priority ,dir) *operators-priority*)))
    (when (some (lambda (op) (member op exp)) ops)
    (multiple-value-bind (op bef af) (devide-infix exp ops dir)
    (return (list (getclname op) (infix-polish bef) (infix-polish af)))))))))

    (defmacro infix (&rest exp)
    "中間記法用マクロ。
    applyarしてinfix-polishする"
    (infix-polish (applyar exp)))

    (infix-polish (apply-ifunction exp)))

    ;{}で中間記法を表す
    (set-macro-character #\} (get-macro-character #\)))
    @@ -149,39 +145,40 @@
    (declare (ignore char))
    (cons 'infix (read-delimited-list #\} stream t))))

    (defun add-operator (priority op &optional cl-name (direction 'left))
    "演算子を追加"
    (unless cl-name
    (setq cl-name op))
    (push op (cdr (nth (ecase direction
    (left (- (* 2 leastpriority) (* 2 priority)))
    (right (- (* 2 leastpriority) (1+ (* 2 priority))))) operators)))
    (push (cons op cl-name) operator-clfunction))

    (defun add-infix-function (fun num &optional cl-name)
    "算術関数を追加"
    (unless cl-name
    (setf cl-name fun))
    (push (cons fun num) arfunction)
    (push (cons fun cl-name) arfunction-clfunction))
    (defun add-operator (priority op &optional clname (direction :left))
    (unless clname
    (setf clname op))
    (setf (gethash op *operators*)
    (make-instance 'infix-function
    :type :operator
    :clname clname
    :numarg 2
    :priority priority
    :direction direction))
    (push op (gethash `(,priority ,direction) *operators-priority*)))

    (defun add-ifunction (fun numarg &optional clname)
    (unless clname
    (setf clname fun))
    (setf (gethash fun *operators*)
    (make-instance 'infix-function
    :type :ifunction
    :clname clname
    :numarg numarg
    :priority nil
    :direction nil)))

    (defun initialize ()
    (setf operators nil)
    (setf operator-clfunction nil)
    (setf arfunction nil)
    (setf arfunction-clfunction nil)
    (dotimes (i leastpriority)
    (push (list 'right) operators)
    (push (list 'left) operators)))
    "演算子及び算術関数に関するデータを初期化する"
    (clrhash *operators-priority*)
    (clrhash *operators*))

    (defun install-default-operators-and-infix-functions ()
    "デフォルトの演算子と算術関数をインストールする"
    (initialize)
    (mapcar #'(lambda (x) (apply #'add-operator x)) default-operators)
    (mapcar #'(lambda (x) (apply #'add-infix-function x)) default-infix-functions)
    (mapcar #'(lambda (x) (apply #'add-ifunction x)) default-infix-functions)
    t)

    ;ロード時に読み込む
    (install-default-operators-and-infix-functions)


  2. zeptometer revised this gist Mar 28, 2011. 1 changed file with 1 addition and 0 deletions.
    1 change: 1 addition & 0 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -2,6 +2,7 @@
    (:use :cl)
    (:export #:add-operator
    #:add-infix-function
    #:initialize
    #:install-default-operators-and-infix-functions))

    (in-package :infix)
  3. zeptometer revised this gist Mar 28, 2011. 1 changed file with 3 additions and 3 deletions.
    6 changes: 3 additions & 3 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -165,13 +165,13 @@
    (push (cons fun cl-name) arfunction-clfunction))

    (defun initialize ()
    (setf operators (make-list (* 2 leastpriority) :initial-element nil))
    (setf operators nil)
    (setf operator-clfunction nil)
    (setf arfunction nil)
    (setf arfunction-clfunction nil)
    (dotimes (i leastpriority)
    (push 'left (nth (* 2 i) operators))
    (push 'right (nth (1+ (* 2 i)) operators))))
    (push (list 'right) operators)
    (push (list 'left) operators)))

    (defun install-default-operators-and-infix-functions ()
    "デフォルトの演算子と算術関数をインストールする"
  4. zeptometer revised this gist Mar 27, 2011. 1 changed file with 3 additions and 0 deletions.
    3 changes: 3 additions & 0 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -149,6 +149,7 @@
    (cons 'infix (read-delimited-list #\} stream t))))

    (defun add-operator (priority op &optional cl-name (direction 'left))
    "演算子を追加"
    (unless cl-name
    (setq cl-name op))
    (push op (cdr (nth (ecase direction
    @@ -157,6 +158,7 @@
    (push (cons op cl-name) operator-clfunction))

    (defun add-infix-function (fun num &optional cl-name)
    "算術関数を追加"
    (unless cl-name
    (setf cl-name fun))
    (push (cons fun num) arfunction)
    @@ -172,6 +174,7 @@
    (push 'right (nth (1+ (* 2 i)) operators))))

    (defun install-default-operators-and-infix-functions ()
    "デフォルトの演算子と算術関数をインストールする"
    (initialize)
    (mapcar #'(lambda (x) (apply #'add-operator x)) default-operators)
    (mapcar #'(lambda (x) (apply #'add-infix-function x)) default-infix-functions)
  5. zeptometer revised this gist Mar 27, 2011. 1 changed file with 3 additions and 2 deletions.
    5 changes: 3 additions & 2 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -49,8 +49,8 @@
    (defvar operators nil "演算子。優先順位の低い順にグループ分け。")
    (defvar operator-clfunction nil "演算子と関数の対応表")

    (defvar arfunction '((sqrt 1) (sin 1) (cos 1) (tan 1) (log 2) (+ 1) (- 1) (! 1) (~ 1)) "算術関数とその引数の一覧")
    (defvar arfunction-clfunction '((sqrt sqrt) (sin sin) (cos cos) (tan tan) (log log) (+ +) (- -) (! not) (~ lognot)) "算術関数とCL関数の対応表")
    (defvar arfunction nil "算術関数とその引数の一覧")
    (defvar arfunction-clfunction nil "算術関数とCL関数の対応表")

    (defvar stack nil)

    @@ -177,6 +177,7 @@
    (mapcar #'(lambda (x) (apply #'add-infix-function x)) default-infix-functions)
    t)

    ;ロード時に読み込む
    (install-default-operators-and-infix-functions)


  6. zeptometer revised this gist Mar 27, 2011. 1 changed file with 97 additions and 24 deletions.
    121 changes: 97 additions & 24 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -1,12 +1,53 @@
    (defpackage :infix
    (:use :cl)
    (:export #:operators
    #:operator-clfunction
    #:arfunction
    #:arfunction-clfunction))

    (defvar operators '((right = += -=) (left ||) (left &&) (left \|) (left ^) (left &) (left == !=) (left < <= > >=) (left >> <<) (left + -) (left * / %) (right **)) "演算子。優先順位の低い順にグループ分け。")
    (defvar operator-clfunction '((= setf) (+= incf) (-= decf) (|| or) (&& and) (\| logior) (^ logor) (& logand) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (>> (lambda (x y) (ash x (- y)))) (<< ash) (+ +) (- -) (* *) (/ /) (% mod) (** expt)) "演算子と関数の対応表")
    (:export #:add-operator
    #:add-infix-function
    #:install-default-operators-and-infix-functions))

    (in-package :infix)

    (defconstant leastpriority 20)

    (defconstant default-operators
    '((1 ** expt right)
    (2 *)
    (2 /)
    (2 % mod)
    (3 +)
    (3 -)
    (4 >> (lambda (x y) (ash x (- y))))
    (4 << ash)
    (5 <)
    (5 <=)
    (5 >)
    (5 >=)
    (6 == =)
    (6 != (lambda (x y) (not (= x y))))
    (7 & logand)
    (8 ^ logxor)
    (9 \| logior)
    (10 && and)
    (11 || or)
    (12 = setf right)
    (12 += incf right)
    (12 -= decf right)))

    (defconstant default-infix-functions
    '((sqrt 1)
    (sin 1)
    (cos 1)
    (tan 1)
    (log 2)
    (loge 1 log)
    (log10 1 (lambda (x) (log x 10)))
    (+ 1)
    (- 1)
    (! 1 not)
    (~ 1 lognot)))


    (defvar operators nil "演算子。優先順位の低い順にグループ分け。")
    (defvar operator-clfunction nil "演算子と関数の対応表")

    (defvar arfunction '((sqrt 1) (sin 1) (cos 1) (tan 1) (log 2) (+ 1) (- 1) (! 1) (~ 1)) "算術関数とその引数の一覧")
    (defvar arfunction-clfunction '((sqrt sqrt) (sin sin) (cos cos) (tan tan) (log log) (+ +) (- -) (! not) (~ lognot)) "算術関数とCL関数の対応表")
    @@ -20,30 +61,30 @@
    (some (lambda (x) (member op (cdr x))) operators))

    (defun arfunctionp (ar)
    (cadr (assoc ar arfunction)))
    (cdr (assoc ar arfunction)))

    (defun op-cl (op)
    "opに対応するCL関数を返す"
    (cadr (assoc op operator-clfunction)))
    (cdr (assoc op operator-clfunction)))

    (defun ar-cl (ar)
    (cadr (assoc ar arfunction-clfunction)))
    (cdr (assoc ar arfunction-clfunction)))

    (defun applyar (exp)
    "算術関数を普通のポーランド記法の形にする
    (applyar '(sqrt a + sin cos b))
    -> '((sqrt a) + (sin (cos b)))"
    (labels ((rec (exp loaded)
    (cond ((null exp)
    (reverse loaded))
    (reverse loaded))
    ((single exp)
    (rec nil (cons (car exp)loaded)))
    (rec nil (cons (car exp)loaded)))
    ((arfunctionp (car exp))
    (multiple-value-bind (exp* rest) (loadar exp)
    (rec (cons exp* rest) loaded)))
    (multiple-value-bind (exp* rest) (loadar exp)
    (rec (cons exp* rest) loaded)))
    ((and (not (arfunctionp (car exp)))
    (operatorp (cadr exp)))
    (rec (cddr exp) (list* (cadr exp) (car exp) loaded))))))
    (rec (cddr exp) (list* (cadr exp) (car exp) loaded))))))
    (rec exp nil)))

    (defun loadar (exp)
    @@ -74,15 +115,15 @@
    (1 + 2 * 3)
    (3)"
    (destructuring-bind (direction &rest ops*) ops
    (labels ((rec (exp ops* stack)
    (if (member (car exp) ops*)
    (ecase direction
    (left (values (car exp) (reverse (cdr exp)) stack))
    (right (values (car exp) (reverse stack) (cdr exp))))
    (rec (cdr exp) ops* (cons (car exp) stack)))))
    (ecase direction
    (left (rec (reverse exp) ops* nil))
    (right (rec exp ops* nil))))))
    (labels ((rec (exp ops* stack)
    (if (member (car exp) ops*)
    (ecase direction
    (left (values (car exp) (reverse (cdr exp)) stack))
    (right (values (car exp) (reverse stack) (cdr exp))))
    (rec (cdr exp) ops* (cons (car exp) stack)))))
    (ecase direction
    (left (rec (reverse exp) ops* nil))
    (right (rec exp ops* nil))))))

    (defun infix-polish (exp)
    "中間記法の式を普通のS式(ポーランド記法)に変換する。"
    @@ -107,3 +148,35 @@
    (declare (ignore char))
    (cons 'infix (read-delimited-list #\} stream t))))

    (defun add-operator (priority op &optional cl-name (direction 'left))
    (unless cl-name
    (setq cl-name op))
    (push op (cdr (nth (ecase direction
    (left (- (* 2 leastpriority) (* 2 priority)))
    (right (- (* 2 leastpriority) (1+ (* 2 priority))))) operators)))
    (push (cons op cl-name) operator-clfunction))

    (defun add-infix-function (fun num &optional cl-name)
    (unless cl-name
    (setf cl-name fun))
    (push (cons fun num) arfunction)
    (push (cons fun cl-name) arfunction-clfunction))

    (defun initialize ()
    (setf operators (make-list (* 2 leastpriority) :initial-element nil))
    (setf operator-clfunction nil)
    (setf arfunction nil)
    (setf arfunction-clfunction nil)
    (dotimes (i leastpriority)
    (push 'left (nth (* 2 i) operators))
    (push 'right (nth (1+ (* 2 i)) operators))))

    (defun install-default-operators-and-infix-functions ()
    (initialize)
    (mapcar #'(lambda (x) (apply #'add-operator x)) default-operators)
    (mapcar #'(lambda (x) (apply #'add-infix-function x)) default-infix-functions)
    t)

    (install-default-operators-and-infix-functions)


  7. zeptometer revised this gist Mar 27, 2011. 1 changed file with 4 additions and 4 deletions.
    8 changes: 4 additions & 4 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -5,11 +5,11 @@
    #:arfunction
    #:arfunction-clfunction))

    (defvar operators '((left or) (left and) (left == !=) (left < <= > >=) (left + -) (left * / %) (right **)) "演算子。優先順位の低い順にグループ分け。")
    (defvar operator-clfunction '((or or) (and and) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (+ +) (- -) (* *) (/ /) (% mod) (** expt)) "演算子と関数の対応表")
    (defvar operators '((right = += -=) (left ||) (left &&) (left \|) (left ^) (left &) (left == !=) (left < <= > >=) (left >> <<) (left + -) (left * / %) (right **)) "演算子。優先順位の低い順にグループ分け。")
    (defvar operator-clfunction '((= setf) (+= incf) (-= decf) (|| or) (&& and) (\| logior) (^ logor) (& logand) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (>> (lambda (x y) (ash x (- y)))) (<< ash) (+ +) (- -) (* *) (/ /) (% mod) (** expt)) "演算子と関数の対応表")

    (defvar arfunction '((sqrt 1) (sin 1) (cos 1) (tan 1) (log 2) (+ 1) (- 1)) "算術関数とその引数の一覧")
    (defvar arfunction-clfunction '((sqrt sqrt) (sin sin) (cos cos) (tan tan) (log log) (+ +) (- -)) "算術関数とCL関数の対応表")
    (defvar arfunction '((sqrt 1) (sin 1) (cos 1) (tan 1) (log 2) (+ 1) (- 1) (! 1) (~ 1)) "算術関数とその引数の一覧")
    (defvar arfunction-clfunction '((sqrt sqrt) (sin sin) (cos cos) (tan tan) (log log) (+ +) (- -) (! not) (~ lognot)) "算術関数とCL関数の対応表")

    (defvar stack nil)

  8. zeptometer revised this gist Mar 27, 2011. 1 changed file with 16 additions and 12 deletions.
    28 changes: 16 additions & 12 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -5,8 +5,8 @@
    #:arfunction
    #:arfunction-clfunction))

    (defvar operators '((or) (and) (== !=) (< <= > >=) (+ -) (* / %) (^)) "演算子。優先順位の低い順にグループ分け。")
    (defvar operator-clfunction '((or or) (and and) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (+ +) (- -) (* *) (/ /) (% mod) (^ expt)) "演算子と関数の対応表")
    (defvar operators '((left or) (left and) (left == !=) (left < <= > >=) (left + -) (left * / %) (right **)) "演算子。優先順位の低い順にグループ分け。")
    (defvar operator-clfunction '((or or) (and and) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (+ +) (- -) (* *) (/ /) (% mod) (** expt)) "演算子と関数の対応表")

    (defvar arfunction '((sqrt 1) (sin 1) (cos 1) (tan 1) (log 2) (+ 1) (- 1)) "算術関数とその引数の一覧")
    (defvar arfunction-clfunction '((sqrt sqrt) (sin sin) (cos cos) (tan tan) (log log) (+ +) (- -)) "算術関数とCL関数の対応表")
    @@ -17,7 +17,7 @@
    (and (consp x) (null (cdr x))))

    (defun operatorp (op)
    (some (lambda (x) (member op x)) operators))
    (some (lambda (x) (member op (cdr x))) operators))

    (defun arfunctionp (ar)
    (cadr (assoc ar arfunction)))
    @@ -62,30 +62,34 @@
    (values (reverse (pop stack)) rest)))

    (defun devide-infix (exp ops)
    "ops中の演算子でexpを分割する。複数出てくる場合は最後のものを。
    "(cdr ops)中の演算子でexpを分割する。(car ops)にある結合を用いる。
    三つの値を返す。
    1: 演算子
    2: 演算子より前の式
    3: 演算子より後の式
    Example:
    (devide-infix '(1 + 2 * 3 - 3) '(+ -))
    (devide-infix '(1 + 2 * 3 - 3) '(left + -))
    -> -
    (1 + 2 * 3)
    (3)"
    (labels ((rec (exp ops after)
    (if (member (car exp) ops)
    (values (car exp) (reverse (cdr exp)) after)
    (rec (cdr exp) ops (cons (car exp) after)))))
    (if (some (lambda (x) (member x exp)) ops)
    (rec (reverse exp) ops nil))))
    (destructuring-bind (direction &rest ops*) ops
    (labels ((rec (exp ops* stack)
    (if (member (car exp) ops*)
    (ecase direction
    (left (values (car exp) (reverse (cdr exp)) stack))
    (right (values (car exp) (reverse stack) (cdr exp))))
    (rec (cdr exp) ops* (cons (car exp) stack)))))
    (ecase direction
    (left (rec (reverse exp) ops* nil))
    (right (rec exp ops* nil))))))

    (defun infix-polish (exp)
    "中間記法の式を普通のS式(ポーランド記法)に変換する。"
    (if (single exp)
    (car exp)
    (dolist (ops operators)
    (when (some (lambda (op) (member op exp)) ops)
    (when (some (lambda (op) (member op exp)) (cdr ops))
    (multiple-value-bind (op bef af) (devide-infix exp ops)
    (return (list (op-cl op) (infix-polish bef) (infix-polish af))))))))

  9. zeptometer revised this gist Mar 27, 2011. 1 changed file with 11 additions and 2 deletions.
    13 changes: 11 additions & 2 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -30,7 +30,9 @@
    (cadr (assoc ar arfunction-clfunction)))

    (defun applyar (exp)
    "算術関数を普通のポーランド記法の形にする"
    "算術関数を普通のポーランド記法の形にする
    (applyar '(sqrt a + sin cos b))
    -> '((sqrt a) + (sin (cos b)))"
    (labels ((rec (exp loaded)
    (cond ((null exp)
    (reverse loaded))
    @@ -45,6 +47,10 @@
    (rec exp nil)))

    (defun loadar (exp)
    "applyar補助関数
    (loadar '(sqrt a + sin cos b))
    -> (sqrt a)
    (+ sin cos b)"
    (destructuring-bind (ar &rest rest) exp
    (push (list (ar-cl ar)) stack)
    (dotimes (i (arfunctionp ar))
    @@ -84,9 +90,12 @@
    (return (list (op-cl op) (infix-polish bef) (infix-polish af))))))))

    (defmacro infix (&rest exp)
    "中間記法用マクロ"
    "中間記法用マクロ。
    applyarしてinfix-polishする"
    (infix-polish (applyar exp)))


    ;{}で中間記法を表す
    (set-macro-character #\} (get-macro-character #\)))

    (set-macro-character #\{
  10. zeptometer revised this gist Mar 27, 2011. 1 changed file with 1 addition and 0 deletions.
    1 change: 1 addition & 0 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -30,6 +30,7 @@
    (cadr (assoc ar arfunction-clfunction)))

    (defun applyar (exp)
    "算術関数を普通のポーランド記法の形にする"
    (labels ((rec (exp loaded)
    (cond ((null exp)
    (reverse loaded))
  11. zeptometer revised this gist Mar 27, 2011. 1 changed file with 47 additions and 24 deletions.
    71 changes: 47 additions & 24 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -1,23 +1,58 @@
    (defpackage :infix
    (:use :cl)
    (:export #:operators
    #:operator-clfunction
    #:arfunction
    #:arfunction-clfunction))

    (defvar operators '((or) (and) (== !=) (< <= > >=) (+ -) (* / %) (^)) "演算子。優先順位の低い順にグループ分け。")
    (defvar clfunction '((or or) (and and) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (+ +) (- -) (* *) (/ /) (% mod) (^ expt)) "演算子と関数の対応表")
    (defvar operator-clfunction '((or or) (and and) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (+ +) (- -) (* *) (/ /) (% mod) (^ expt)) "演算子と関数の対応表")

    (defvar arfunction '((sqrt 1) (sin 1) (cos 1) (tan 1) (log 2) (+ 1) (- 1)) "算術関数とその引数の一覧")
    (defvar arfunction-clfunction '((sqrt sqrt) (sin sin) (cos cos) (tan tan) (log log) (+ +) (- -)) "算術関数とCL関数の対応表")

    (defvar stack nil)

    (defun single (x)
    (and (consp x) (null (cdr x))))

    ;(defun operatorp (op)
    ; (some (lambda (x) (member op x)) operators))
    (defun operatorp (op)
    (some (lambda (x) (member op x)) operators))

    ;(defun infixp (exp)
    ; "expが中間記法の時、tを返す"
    ; (and (consp exp)
    ; (not (operatorp (car exp)))
    ; (operatorp (cadr exp))
    ; (or (infixp (cddr exp))
    ; (single (cddr exp)))))
    (defun arfunctionp (ar)
    (cadr (assoc ar arfunction)))

    (defun op-cl (op)
    "opに対応するCL関数を返す"
    (cadr (assoc op clfunction)))
    (cadr (assoc op operator-clfunction)))

    (defun ar-cl (ar)
    (cadr (assoc ar arfunction-clfunction)))

    (defun applyar (exp)
    (labels ((rec (exp loaded)
    (cond ((null exp)
    (reverse loaded))
    ((single exp)
    (rec nil (cons (car exp)loaded)))
    ((arfunctionp (car exp))
    (multiple-value-bind (exp* rest) (loadar exp)
    (rec (cons exp* rest) loaded)))
    ((and (not (arfunctionp (car exp)))
    (operatorp (cadr exp)))
    (rec (cddr exp) (list* (cadr exp) (car exp) loaded))))))
    (rec exp nil)))

    (defun loadar (exp)
    (destructuring-bind (ar &rest rest) exp
    (push (list (ar-cl ar)) stack)
    (dotimes (i (arfunctionp ar))
    (if (arfunctionp (car rest))
    (multiple-value-bind (exp* rest*) (loadar rest)
    (push exp* (car stack))
    (setf rest rest*))
    (push (pop rest) (car stack))))
    (values (reverse (pop stack)) rest)))

    (defun devide-infix (exp ops)
    "ops中の演算子でexpを分割する。複数出てくる場合は最後のものを。
    @@ -49,7 +84,7 @@

    (defmacro infix (&rest exp)
    "中間記法用マクロ"
    (infix-polish exp))
    (infix-polish (applyar exp)))

    (set-macro-character #\} (get-macro-character #\)))

    @@ -58,15 +93,3 @@
    (declare (ignore char))
    (cons 'infix (read-delimited-list #\} stream t))))

    ;(defun niji (a b c)
    ; {{(- b) + (sqrt {b ^ 2 - 4 * a * c})} / {2 * a}})

    ;(defun niji* (a b c)
    ; {{- b + sqrt {b ^ 2 - 4 * a * c}} / {2 * a}})

    ;(defun test (n)
    ; {n * (1+ n) / 2})

    ;(defun test2 (a d n)
    ; {n * {2 * a + {n - 1} * d} / 2})

  12. zeptometer revised this gist Mar 26, 2011. 1 changed file with 2 additions and 2 deletions.
    4 changes: 2 additions & 2 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -67,6 +67,6 @@
    ;(defun test (n)
    ; {n * (1+ n) / 2})

    (defun test2 (a d n)
    {n * {2 * a + {n - 1} * d} / 2})
    ;(defun test2 (a d n)
    ; {n * {2 * a + {n - 1} * d} / 2})

  13. zeptometer revised this gist Mar 26, 2011. 1 changed file with 28 additions and 18 deletions.
    46 changes: 28 additions & 18 deletions infix.lisp
    View file
    Original file line number Diff line number Diff line change
    @@ -1,19 +1,19 @@
    (defvar operators '( (||) (&&) (^) (&) (== !=) (< <= > >=) (>>> >> <<) (+ -) (* / %)) "演算子。優先順位の低い順にグループ分け。")
    (defvar clfunction '((|| or) (&& and) (^ logxor) (& logand) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (>>> (lambda (x y) (ash x (- y))))(>> (lambda (x y) (lsh x (- y)))) (<< lsh) (+ +) (- -) (* *) (/ /) (% mod) (^ expt)) "演算子と関数の対応表")
    (defvar operators '((or) (and) (== !=) (< <= > >=) (+ -) (* / %) (^)) "演算子。優先順位の低い順にグループ分け。")
    (defvar clfunction '((or or) (and and) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (+ +) (- -) (* *) (/ /) (% mod) (^ expt)) "演算子と関数の対応表")

    (defun single (x)
    (and (consp x) (null (cdr x))))

    (defun operatorp (op)
    (some (lambda (x) (member op x)) operators))
    ;(defun operatorp (op)
    ; (some (lambda (x) (member op x)) operators))

    (defun infixp (exp)
    "expが中間記法の時、tを返す"
    (and (consp exp)
    (not (operatorp (car exp)))
    (operatorp (cadr exp))
    (or (infixp (cddr exp))
    (single (cddr exp)))))
    ;(defun infixp (exp)
    ; "expが中間記法の時、tを返す"
    ; (and (consp exp)
    ; (not (operatorp (car exp)))
    ; (operatorp (cadr exp))
    ; (or (infixp (cddr exp))
    ; (single (cddr exp)))))

    (defun op-cl (op)
    "opに対応するCL関数を返す"
    @@ -40,15 +40,12 @@

    (defun infix-polish (exp)
    "中間記法の式を普通のS式(ポーランド記法)に変換する。"
    (if (infixp exp)
    (if (single exp)
    (car exp)
    (dolist (ops operators)
    (when (some (lambda (op) (member op exp)) ops)
    (multiple-value-bind (op bef af) (devide-infix exp ops)
    (return (list (op-cl op) (infix-polish bef) (infix-polish af))))))
    (let ((x (car exp)))
    (if (infixp x)
    (infix-polish x)
    x))))
    (return (list (op-cl op) (infix-polish bef) (infix-polish af))))))))

    (defmacro infix (&rest exp)
    "中間記法用マクロ"
    @@ -59,4 +56,17 @@
    (set-macro-character #\{
    (lambda (stream char)
    (declare (ignore char))
    (cons 'infix (read-delimited-list #\} stream t))))
    (cons 'infix (read-delimited-list #\} stream t))))

    ;(defun niji (a b c)
    ; {{(- b) + (sqrt {b ^ 2 - 4 * a * c})} / {2 * a}})

    ;(defun niji* (a b c)
    ; {{- b + sqrt {b ^ 2 - 4 * a * c}} / {2 * a}})

    ;(defun test (n)
    ; {n * (1+ n) / 2})

    (defun test2 (a d n)
    {n * {2 * a + {n - 1} * d} / 2})

  14. zeptometer renamed this gist Mar 26, 2011. 1 changed file with 0 additions and 0 deletions.
    0 CL infix notion macro → infix.lisp
    View file
    File renamed without changes.
  15. zeptometer renamed this gist Mar 26, 2011. 1 changed file with 0 additions and 0 deletions.
    0 gistfile1.cl → CL infix notion macro
    View file
    File renamed without changes.
  16. zeptometer created this gist Mar 26, 2011.
    62 changes: 62 additions & 0 deletions gistfile1.cl
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,62 @@
    (defvar operators '( (||) (&&) (^) (&) (== !=) (< <= > >=) (>>> >> <<) (+ -) (* / %)) "演算子。優先順位の低い順にグループ分け。")
    (defvar clfunction '((|| or) (&& and) (^ logxor) (& logand) (== =) (!= (lambda (x y) (not (= x y)))) (< <) (<= <=) (> >) (>= >=) (>>> (lambda (x y) (ash x (- y))))(>> (lambda (x y) (lsh x (- y)))) (<< lsh) (+ +) (- -) (* *) (/ /) (% mod) (^ expt)) "演算子と関数の対応表")

    (defun single (x)
    (and (consp x) (null (cdr x))))

    (defun operatorp (op)
    (some (lambda (x) (member op x)) operators))

    (defun infixp (exp)
    "expが中間記法の時、tを返す"
    (and (consp exp)
    (not (operatorp (car exp)))
    (operatorp (cadr exp))
    (or (infixp (cddr exp))
    (single (cddr exp)))))

    (defun op-cl (op)
    "opに対応するCL関数を返す"
    (cadr (assoc op clfunction)))

    (defun devide-infix (exp ops)
    "ops中の演算子でexpを分割する。複数出てくる場合は最後のものを。
    三つの値を返す。
    1: 演算子
    2: 演算子より前の式
    3: 演算子より後の式
    Example:
    (devide-infix '(1 + 2 * 3 - 3) '(+ -))
    -> -
    (1 + 2 * 3)
    (3)"
    (labels ((rec (exp ops after)
    (if (member (car exp) ops)
    (values (car exp) (reverse (cdr exp)) after)
    (rec (cdr exp) ops (cons (car exp) after)))))
    (if (some (lambda (x) (member x exp)) ops)
    (rec (reverse exp) ops nil))))

    (defun infix-polish (exp)
    "中間記法の式を普通のS式(ポーランド記法)に変換する。"
    (if (infixp exp)
    (dolist (ops operators)
    (when (some (lambda (op) (member op exp)) ops)
    (multiple-value-bind (op bef af) (devide-infix exp ops)
    (return (list (op-cl op) (infix-polish bef) (infix-polish af))))))
    (let ((x (car exp)))
    (if (infixp x)
    (infix-polish x)
    x))))

    (defmacro infix (&rest exp)
    "中間記法用マクロ"
    (infix-polish exp))

    (set-macro-character #\} (get-macro-character #\)))

    (set-macro-character #\{
    (lambda (stream char)
    (declare (ignore char))
    (cons 'infix (read-delimited-list #\} stream t))))