LISP to C++

;;;----------------------------------->EC-A<---------------------------------------;;;
;;;               Команда построения переходных кривых для автодорог               ;;;
;;;                            ECA.lsp Version 1.0 X ;;;
;;;                           Автор: Протасов Георгий X ;;;
;;; Программа строит переходные кривые для автодорог и сопрягает их заданным       ;;;
;;; радиусом X ;;;
;;;--------------------------------------------------------------------------------;;;

;Основная функция построения переходных кривых и радиуса
(DEFUN EC-A (/ pt1 pt2 pt3 pt4 pt5 alpha tfc r L0 dL c L a1 a2
      sysvar-name sysvar-save error-save
      TAN FINDPT)
   (SETQ sysvar-name (LIST "CMDECHO"
         "ANGDIR"
         "AUNITS"
         "OSMODE");LIST
      error-save *error*
      sysvar-save (MAPCAR 'GETVAR sysvar-name)
      );SETQ
   (DEFUN *error* (msg)
      (IF  error-save (SETQ *error* error-save))
      (IF msg (PRINC "\nВыполнение функции прервано "))
      ; Восстановление значений системных переменных
      (MAPCAR 'SETVAR sysvar-name sysvar-save)
      (PRINC)
      );DEFUN

   ;Функция тангенса
   (DEFUN TAN (x)
      (/ (SIN x) (COS x))
      );DEFUN

   ;Вычисление координат точек переходной кривой
   (DEFUN FINDPT (L / x y)
      (SETQ x (* L (- 1 (/ (* (/ (* L L) c) (/ (* L L) c)) 40)))
         y (/ (* L L L (- 1 (/ (* (/ (* L L) c) (/ (* L L) c)) 56))) (* 6 c))
         );SETQ
      (TRANS (LIST x y) 1 0)
      );DEFUN
   ;Основной текст функции
   (SETVAR "CMDECHO" 0)
   (COMMAND "_.undo" "_begin")
   (PRINC "\nПостроение переходных кривых для автодорог")
   (INITGET 9)
   (SETQ pt1 (GETPOINT "\nУкажите точку на первой линии тангенса: "))
   (INITGET 41)
   (SETQ pt2 (GETPOINT "\nУкажите вершину угла: "))
   (INITGET 41)
   (SETQ pt3 (GETPOINT "\nУкажите точку на второй линии тангенса: "))
   (SETQ alpha (ABS (- (ANGLE pt2 pt1) (ANGLE pt2 pt3)))
      alpha (IF (< alpha pi) alpha (- (* 2 pi) alpha))
      alpha (- pi alpha)
      );SETQ
   (COND
      ((EQ *ecr NIL)
         (INITGET 7)
         (SETQ *ecr (GETREAL "\nРадиус: ")))
      (T (PRINC "\nРадиус <")
         (PRINC *ecr)
         (PRINC ">: ")
         (INITGET 6)
         (SETQ r *ecr
            *ecr (GETREAL))
         (COND
            ((EQ *ecr NIL) (SETQ *ecr r))
            );COND
         )
      );COND
   (COND
      ((EQ *ecL0 NIL)
         (INITGET 7)
         (SETQ *ecL0 (GETREAL "\nДлина: ")))
      (T (PRINC "\nДлина <")
         (PRINC *ecL0)
         (PRINC ">: ")
         (INITGET 6)
         (SETQ L0 *ecL0
            *ecL0 (GETREAL))
         (COND
            ((EQ *ecL0 NIL) (SETQ *ecL0 L0))
            );COND
         )
      );COND
   (COND
      ((EQ *ecdL NIL)
         (INITGET 7)
         (SETQ *ecdL (GETREAL "\nДлина сегмента: ")))
      (T (PRINC "\nДлина сегмента <")
         (PRINC *ecdL)
         (PRINC ">: ")
         (INITGET 6)
         (SETQ dL *ecdL
            *ecdL (GETREAL))
         (COND
            ((EQ *ecdL NIL) (SETQ *ecdL dL))
            );COND
         )
      );COND
   (SETQ
      c (* *ecL0 *ecr)
      tfc (-
         (+ (/ (* *ecL0 *ecL0 (TAN (/ alpha 2))) 24 *ecr)
            (/ *ecL0 2)
            (* *ecr (TAN (/ alpha 2))))
         (/ (* *ecL0 *ecL0 *ecL0) 240 (* *ecr *ecr)))
      pt1 (POLAR pt2 (ANGLE pt2 pt1) tfc)
      pt3 (POLAR pt2 (ANGLE pt2 pt3) tfc)
      L *ecdL
      );SETQ
   ;Начало построений
(PRINT tfc)
(PRINT alpha)
   (SETVAR "ANGDIR" 0)
   (SETVAR "AUNITS" 0)
   (SETVAR "OSMODE" 0)
   (COMMAND "_.ucs" "_3" pt1 pt2 pt3)
   (ENTMAKE '((0 . "POLYLINE") (66 . 1)))
   (ENTMAKE (CONS '(0 . "VERTEX") (LIST (APPEND '(10) (TRANS '(0.0 0.0) 1 0)))))
   (WHILE (< L *ecL0)
      (ENTMAKE (CONS '(0 . "VERTEX") (LIST (APPEND '(10) (FINDPT L)))))
      (SETQ L (+ L *ecdL))
      );WHILE
   (ENTMAKE (CONS '(0 . "VERTEX") (LIST (APPEND '(10) (SETQ pt4 (FINDPT *ecL0))))))
   (ENTMAKE '((0 . "SEQEND")))
   (COMMAND "_.ucs" "_previous")
   (COMMAND "_.ucs" "_3" pt3 pt2 pt1)
   (ENTMAKE '((0 . "POLYLINE") (66 . 1)))
   (ENTMAKE (CONS '(0 . "VERTEX") (LIST (APPEND '(10) (TRANS '(0.0 0.0) 1 0)))))
   (SETQ L *ecdL)
   (WHILE (< L *ecL0)
      (ENTMAKE (CONS '(0 . "VERTEX") (LIST (APPEND '(10) (FINDPT L)))))
      (SETQ L (+ L *ecdL))
      );WHILE
   (ENTMAKE (CONS '(0 . "VERTEX") (LIST (APPEND '(10) (SETQ pt5 (FINDPT *ecL0))))))
   (ENTMAKE '((0 . "SEQEND")))
   (COMMAND "_.ucs" "_previous")
   (SETQ
      pt4 (TRANS pt4 0 1)
      pt5 (TRANS pt5 0 1)
      a1 (ANGLE pt2 pt1)
      a2 (ANGLE pt2 pt3)
      );SETQ
   (IF (< (ABS (- a1 a2)) pi)
      (IF (>= a1 a2)
         (COMMAND "_.arc" pt4 "_e" pt5 "_r" *ecr)
         (COMMAND "_.arc" pt5 "_e" pt4 "_r" *ecr)
         );IF
      (IF (>= a1 a2)
         (COMMAND "_.arc" pt5 "_e" pt4 "_r" *ecr)
         (COMMAND "_.arc" pt4 "_e" pt5 "_r" *ecr)
         );IF
      );IF
   (COMMAND "_.undo" "_end")
   (MAPCAR 'SETVAR sysvar-name sysvar-save)
   (SETQ *error* error-save
      );SETQ
   (PRINC)
   );DEFUN

(IF (OR (NULL C:EC-A)
      (NOT (LISTP C:EC-A))
      );OR
   (DEFUN C:EC-A ()
      (EC-A)
      );DEFUN
   );IF
(PRINC "\neca.lsp загружен... ")
(PRINC "\nДобавлена команда EC-A...")
(PRINC)