Регистрация | Войти
Lisp — программируемый язык программирования
infix algebraic expressions to lisp code
Автор: gzip4 - 2012-02-22T14:27:52.000000+04:00
;;;;
;;;; GPLv3, by gzip4 (gzip4ever@gmail.com)
;;;;
;;; convert usual infix algebraic expressions to lisp code
;;; with simplification of constant terms
;;;
;;; ex: (~> 2 2) -> (~> 2 * 2) -> 4
;;;     (~> 2 + 2) -> 4
;;;     (~> 2 + 2 2) -> (~> 2 + 2 * 2) -> 6
;;;     (~> (2 + 2) * 3) -> 12
;;;     (~> sin pi) -> 1.2246063538223773D-16
;;;     (~> sin pi / 2) -> (~> (sin pi) / 2) -> 6.123031769111886D-17
;;;     (~> sin (pi / 2)) -> 1.0D0
;;;     (~> 2 sin (pi / 2)) -> 2.0D0
;;;     (let ((x 3)) (~> x sin (pi / 2))) -> (~> x * (sin (pi / 2))) -> 3.0D0


(defpackage #:infix-notation (:use #:cl))

(in-package #:infix-notation)

(defun func-p (x)
  (handler-case (functionp (symbol-function x))
    (error ())
)
)


(defun q1-number (a &optional s)
  (let ((next (second a)))
    (if (and next (not (find next '(+ - * /))))
        (cons (car a) (q1 (cons '* (cdr a)) s))
        (cons (car a) (q1 (cdr a) s))
)
)
)


(defun q1-cons (a &optional s)
  (if (func-p (caar a))
      (cons (cons (caar a) (q1 (cadar a))) (q1 (cdr a) s))
      (append (q1 (car a)) (q1 (cdr a) s))
)
)


(defun q1-symbol (a &optional s)
  (let ((op-p (find (car a) '(+ - * /))))
    (when (and op-p (or (null (cdr a)) (find (second a) '(+ - * /))))
      (error "Malformed expression: ~s" a)
)

    (cond
      ((and (null s) op-p)
       (q1 (cdr a) (cons (car a) s))
)

      ((find (car a) '(* /))
       (if (find (car s) '(* /))
           (cons (car s) (q1 (cdr a) (cons (car a) (cdr s))))
           (q1 (cdr a) (cons (car a) s))
)
)

      ((find (car a) '(+ -))
       (cons (car s) (q1 (cdr a) (cons (car a) (cdr s))))
)

      ((func-p (car a))
       (q1 (cons (list (car a) (cadr a)) (cddr a)) s)
)

      (:var (q1-number a s))
)
)
)

 
(defun q1 (a &optional s)
  "Infix -> RPN"
  (if (null a)
      s
      (if (not (consp a))
          (q1 (list a) s)
          (etypecase (car a)
            (number (q1-number a s))
            (cons (q1-cons a s))
            (symbol (q1-symbol a s))
)
)
)
)

 

(defun q2 (a &optional s)
  "RPN -> LISP. Simplify constant expressions."
  (if (null a)
      (car s)
      (etypecase (car a)
        (number (q2 (cdr a) (cons (car a) s)))
        (symbol
         (if (find (car a) '(+ - * /))
             (let* ((o2 (pop s)) (o1 (pop s)) (ls (list (car a) o1 o2))
                    (rt (if (every 'numberp (list o1 o2)) (eval ls) ls))
)

               (q2 (cdr a) (cons rt s))
)

             (q2 (cdr a) (cons (car a) s))
)
)

        (cons (q2 (cdr a) (cons (list (caar a) (q2 (cdar a))) s)))
)
)
)



(defmacro cl-user::~> (&rest args)
  "Infix -> LISP"
  (q2 (q1 args))
)

@2009-2013 lisper.ru