Infix mode for Common Lisp

infix-mode.lisp

(defparameter *infix-operator-order* '((!) (^ :reverse) (* /) (+ -) (> < >= <= =) (and) (or) (eql)))

(defparameter *infix-operator-set* '(+ * ^ - / ! = and or eql))

(defparameter *unary-operator-set* '(!))

(defparameter *infix-operator-hash* (let ((local-hash (make-hash-table)))
                                      (setf (gethash '+ local-hash) '+)
                                      (setf (gethash '* local-hash) '*)
                                      (setf (gethash '^ local-hash) 'expt)
                                      (setf (gethash '- local-hash) '-)
                                      (setf (gethash '/ local-hash) '/)
                                      (setf (gethash '! local-hash) 'gamma)
                                      (setf (gethash '= local-hash) '=)
                                      (setf (gethash 'and local-hash) 'and)
                                      (setf (gethash 'or local-hash) 'or)
                                      (setf (gethash 'eql local-hash) 'eql)
                                      local-hash))



(define-condition orphane-operation (error)
  ((errorvalue :initarg :errorvalue
             :initform nil
             :accessor errorvalue))
  (:report (lambda (condition stream)
                   (format stream "Unexpected operation at ~a.~&" (errorvalue condition)))))

(define-condition missing-operation (error)
  ((errorvalue :initarg :errorvalue
             :initform nil
             :accessor errorvalue))
  (:report (lambda (condition stream)
                   (format stream "Expected operation, found value at ~a instead.~&" (errorvalue condition)))))


(define-condition wrong-operation-name (error)
  ((errorvalue :initarg :errorvalue
               :initform nil
               :accessor errorvalue))
  (:report (lambda (condition stream)
                   (format stream " ~a is not an operation.~&" (errorvalue condition)))))


(define-condition wrong-operation-order (error)
  ((errorvalue :initarg :errorvalue
               :initform nil
               :accessor errorvalue))
  (:report (lambda (condition stream)
                   (format stream "Too many operations of type ~a.~&" (errorvalue condition)))))






(defun split-by-comma (list)
  (let ((answer  nil) (subanswer nil))
    (dolist (obj list)
      (if (eql obj :infix-comma)
        (progn (push (reverse subanswer) answer)
               (setf subanswer nil))
        (push obj subanswer)))
    (push (reverse subanswer) answer)
    (reverse answer)))

(defun sanitize-parenthesis-falcon (ls)
  (if (and (listp ls)  (eql (car ls) :prefix-mode))
    (return-from sanitize-parenthesis-falcon nil))
  (loop :for i :from 0
        :for elem :in ls
        :when (listp elem)
          :do (sanitize-parenthesis-falcon elem)
              (when (and (= 1 (length (elt ls i))))
                (setf (elt ls i) (car (elt ls i))))))


(defun sanitize-parenthesis-monroth (list)
  (if (and (listp list) (not (eql (car list) :prefix-mode)))
    (progn (dolist (obj list)
                   (sanitize-parenthesis-monroth obj))
           (if (null (cdr list))
               (progn (setf (cdr list) (list (car list)))
                      (setf (car list) 'eval))))))


(defun deinfexize-structure (global-list)
 (declare (optimize (safety 3) (debug 3)))
 (cond
   ((find global-list *infix-operator-set*)
    (list global-list 'orphane-operation))    ;инфиксное выражение не может начинаться с операции
  ((atom global-list)
   nil)                                      ;но может начинаться с чего-то другого
  ((eql (car global-list) :prefix-mode)
   (return-from deinfexize-structure nil))                                      ;наличие ключа :prefix-mode защищает её от попытки деинфиксации
  (t
   (loop :with list := global-list
         :with error := nil
         :until (null list)
         :do (setf error (deinfexize-structure (car list)))
         :when error
           :do (return-from deinfexize-structure (push (car list) error))
         :when (and (cdr list) (listp (cadr list)))
           :do (unless (eql (caadr list) :prefix-mode) ;наличие ключа :prefix-mode защищает её от попытки деинфиксации
                 (setf (cadr list) (split-by-comma (cadr list))) ;разбиваем скобку на аргументы
                 (dolist (argument (cadr list))
                   (setf error (deinfexize-structure argument)) ;обрабатываем аргументы
                   (when error (return-from deinfexize-structure (push argument error)))))
               (setf (car list) (cons (car list) (cadr list))) ;запихиваем аргументы к названию функции
               (pop (cdr list))
         :if (find (cadr list) *infix-operator-set*)
           :do (if (find (cadr list) *unary-operator-set*)
                   (setf (cddr list) (cons (car list) (cddr list)))) ;для униморфности доб
               (pop list)
               (when (null (cdr list))  ;должно быть что-то после неё
                 (return-from deinfexize-structure (list (car list) 'orphane-operation)))
               (pop list)
         :else
           :do (if (null (cdr list)) ;но сама операция должна быть, если лист ещё не кончился
                   (setf list nil)
                   (return-from deinfexize-structure (list (car list) 'missing-operation))))

   ;;расстановка скобок вокруг операций на данном уровне
   (dolist (turn *infix-operator-order*)
     (unless (find :ignore turn)
       (if (find :reverse turn)

           (loop :with list := (reverse global-list)
                 :with answer := nil
                 :until (null (cdr list))
                 :if (find (cadr list) turn)
                   :do (if (find (cadr list) *unary-operator-set*)
                           (setf (car list) (list (gethash (cadr list) *infix-operator-hash*) (first list))
                                 (car list) (list (gethash (cadr list) *infix-operator-hash*) (third list) (first list))))
                       (setf (cdr list) (cdddr list))
                 :else
                   :do (push (pop list) answer)
                       (push (pop list) answer)
                 :finally (push (pop list) answer)
                          (setf (car global-list) (car answer)
                                (cdr global-list) (cdr answer)))

           (loop :with list := global-list
                 :until (null (cdr list))
                 :if (find (cadr list) turn)
                   :do (if (find (cadr list) *unary-operator-set*)
                           (setf (car list) (list (gethash (cadr list) *infix-operator-hash*) (first list))
                                 (car list) (list (gethash (cadr list) *infix-operator-hash*) (first list) (third list))))
                       (setf (cdr list) (cdddr list))
                 :else
                   :do (pop list)
                       (pop list))))))))

  (sanitize-parenthesis-falcon global-list)


  nil)