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)

  (if (find global-list *infix-operator-set*)
    (return-from deinfexize-structure (list global-list 'orphane-operation)))    ;инфиксное выражение не может начинаться с операции
  (if (atom global-list)
    (return-from deinfexize-structure nil))                                      ;но может начинаться с чего-то другого
  (if (eql (car global-list) :prefix-mode)
    (return-from deinfexize-structure nil))                                      ;наличие ключа :prefix-mode защищает её от попытки деинфиксации

  (let ((list global-list) error)
    (do () ((null list))
      ;; проверка первого элемента листа
      (setf error (deinfexize-structure (car list)))
      (if error (return-from deinfexize-structure (push (car list) error)))
      ;; деинфиксация случая когда у нас f (x)
      (if (cdr list) (if  (listp (cadr list))
                       (progn (if (not (eql (caadr list) :prefix-mode))                       ;наличие ключа :prefix-mode защищает её от попытки деинфиксации
                                (progn (setf (cadr list) (split-by-comma (cadr list)))        ;разбиваем скобку на аргументы
                                       (dolist (argument (cadr list))
                                               (setf error (deinfexize-structure argument))   ;обрабатываем аргументы
                                               (if error (return-from deinfexize-structure (push argument error))))))
                              (setf (car list) (cons (car list) (cadr list)))                 ;запихиваем аргументы к названию функции
                              (setf (cdr list) (cddr list)))))                                ;убираем старое место аргументов)


      ;; обработка корректности написания операций
      (if (find (cadr list) *infix-operator-set*)                                          ;просматриваем следующую операцию
        (progn (if (find (cadr list) *unary-operator-set*)
                 (setf (cddr list) (cons (car list) (cddr list))))          ;для униморфности добавляем второй аргумент унарным операциям
               (pop list)
               (if (null (cdr list))                                        ;должно быть что-то после неё
                 (return-from deinfexize-structure (list (car list) 'orphane-operation)))
               (pop list))
        (if (not (null (cdr list)))                                         ;но сама операция должна быть, если лист ещё не кончился
          (return-from deinfexize-structure (list (car list) 'missing-operation))
          (pop list)))))

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

              (let ((list (reverse global-list)) answer)
                (do () ((null (cdr list)))
                  (if (find (cadr list) turn)
                    (progn (if (find (cadr list) *unary-operator-set*)
                             (setf (car list) (list (gethash (cadr list) *infix-operator-hash*) (first list)))
                             (setf (car list) (list (gethash (cadr list) *infix-operator-hash*) (third list) (first list))))
                           (setf (cdr list) (cdddr list)))
                    (progn (push (pop list) answer)
                           (push (pop list) answer))))
                (push (pop list) answer)
                (setf (car global-list) (car answer))
                (setf (cdr global-list) (cdr answer)))

              (let ((list global-list))
                (do () ((null (cdr list)))
                  (if (find (cadr list) turn)
                    (progn (if (find (cadr list) *unary-operator-set*)
                             (setf (car list) (list (gethash (cadr list) *infix-operator-hash*) (first list)))
                             (setf (car list) (list (gethash (cadr list) *infix-operator-hash*) (first list) (third list))))
                           (setf (cdr list) (cdddr list)))
                    (progn (pop list)
                           (pop list))))))))

  (sanitize-parenthesis-falcon global-list)


  nil)