программно определить фигуру

;;;Тексты отрисовываются текущей высотой
;;;Чтобы изменить высоту текста, нужно в командной строке набрать
;;; TEXTSIZE и задать нужную высоту текста
(defun C:DZ8 (/ el pt en lst dst)
  (setvar "CMDECHO" 0)
  (if (getvar "PLINETYPE")
    (setvar "PLINETYPE" 2)
  ) ;_ end of if
  (while (and
       (setq el (entlast)) ;_ Запоминаем последний примитив
       (setq pt (getpoint "\nУкажите точку внутри области <выход>: "))
     ) ;_ end of and
    (command "_-BOUNDARY" "_A" "_I" "_N" "_N" "_O" "_P"    "" pt "") ;_ end of command
 ;_ end of command
    (while (> (getvar "CMDACTIVE") 0) (command ""))
    (setq en (entlast))
    (cond
      ((equal el en)
       ;;Контур не создан
       (alert "Точка вне контура")
      )
      ((and (not (equal en el)) ;_ Контур создан
        (= (cdr (assoc 0 (entget en))) "LWPOLYLINE") ;_ Контур полилиния
       ) ;_ end of and
;;;Анализируем контур
;;;В lst координаты полилинии
       (setq lst (massoc 10 (entget en)))
       (cond
     ((= (length lst) 4)
;;;Какой-то 4 угольник
;;;Какой?
      (cond
;;;Параллелограмм?
;;;Признак параллелограмма - 4 угольник, у которого противолежащие стороны параллельны
        ((and (parallelp (nth 0 lst)
                 (nth 1 lst)
                 (nth 2 lst)
                 (nth 3 lst)
          ) ;_ end of parallelp
          (parallelp (nth 1 lst)
                 (nth 2 lst)
                 (nth 0 lst)
                 (nth 3 lst)
          ) ;_ end of parallelp
         ) ;_ end of and
;;;Провереряем не является ли параллелограмм ромбом или квадратом
         (if
;;;Ромб - параллелограмм, диагонали которого пересекаются под прямым углом
           (equal
         (3d_angw1w2
           (mapcar '- (nth 0 lst) (nth 2 lst)) ;_ Формируем 1-й вектор
           (mapcar '- (nth 1 lst) (nth 3 lst)) ;_ Формируем 2-й вектор
         ) ;_ end of 3d_angw1w2
         (* PI 0.5)
         1e-6 ;_ С точностью до 6 знаков после запятой
           ) ;_ end ofequal
;;;Да, это ромб (квадрат частный случай ромба)
;;;Квадрат - это ромб, все стороны которого равны
        (if
          (and
            (setq dst ;_ Список длин сторон
               (mapcar 'distance
                   (append lst (list (car lst)))
                   (cdr (append lst (list (car lst))))
               ) ;_ end of mapcar
            ) ;_ end of setq
            (apply
              'and
              (mapcar '(lambda (x) (equal (car dst) x 1e-6)) dst)
            ) ;_ end of apply
            ;;Равны ли расстояния

;;;============================================================================================================
;;; Ниже идет проверка, что все углы равны 90 градусам
;;; - диагонали пересекаются под прямым углом
;;; - стороны равны
;;; - угол между сторонми 90 градусов
;;;============================================================================================================
                                 (setq dst  ;_ Список углов между сторонами
                                        (mapcar '(lambda(x y)
                                                   (3d_angw1w2 x y)
                                                   )
                                                (append
                                               (setq dst  ;;;Вектора  
                                                 (mapcar '(lambda(x y)
                                                            (mapcar '- x y)
                                                            ;(cons x (list y))
                                                            )  
                                                   (append lst (list(car lst))) (cdr (append lst (list(car lst))))
                                                         )
                                                     )
                                               (list (car dst))
                                               )
                                                (cdr (append dst (list (car dst))))
                                                )
                                       )
                                 (apply 'and (mapcar '(lambda(x)(equal x (* PI 0.5) 1e-6)) dst))
;;;============================================================================================================
          ) ;_ end ofand

           (text-draw "КВАДРАТ" pt (getvar "TEXTSIZE") 0 "_M") ;_ Это квадрат
           (text-draw "РОМБ" pt (getvar "TEXTSIZE") 0 "_M") ;_ Это ромб
        ) ;_ end of if
               ;;;Проверяем, не является ли он прямоугольником
               (if (and
;;;============================================================================================================
;;; Ниже идет проверка, что все углы равны 90 градусам
;;;============================================================================================================
                    (setq dst (get-angle-between-side lst))  ;_ Список углов между сторонами
                    (apply 'and (mapcar '(lambda(x)(equal x (* PI 0.5) 1e-6)) dst))
;;;============================================================================================================
                     )
                 (text-draw "ПРЯМОУГОЛЬНИК"
               pt
               (getvar "TEXTSIZE")
               0
               "_M"
        ) ;_ Это параллелограмм
        (text-draw "ПАРАЛЛЕЛОГРАММ"
               pt
               (getvar "TEXTSIZE")
               0
               "_M"
        ) ;_ Это параллелограмм
                 )
         ) ;_ end of if
        )
;;;Трапеция ли? Признак трапеции - 4 угольник, у которого одна пара паралленьных сторон
        ((or (parallelp (nth 0 lst)
                (nth 1 lst)
                (nth 2 lst)
                (nth 3 lst)
         ) ;_ end of parallelp
         (parallelp (nth 1 lst)
                (nth 2 lst)
                (nth 0 lst)
                (nth 3 lst)
         ) ;_ end of parallelp
         ) ;_ end of or
         (text-draw "ТРАПЕЦИЯ" pt (getvar "TEXTSIZE") 0 "_M")
        )
        (t (alert "Не обрабатываемый 4 угольгик"))
      ) ;_ end of cond
     )
         ((= (length lst) 3)  ;;;Треугольник
          (setq dst (append lst (list (car lst))))
          (setq dst (mapcar 'distance dst (cdr dst)))
          (cond ((apply 'and (mapcar '(lambda(x)(equal (car dst) x 1e-6)) dst))
                 (text-draw "ТРЕУГОЛЬНИК РАВНОСТОРОННИЙ" pt (getvar "TEXTSIZE") 0 "_M")
                 )
                ((or (equal (nth 0 dst)(nth 1 dst) 1e-6)
                     (equal (nth 0 dst)(nth 2 dst) 1e-6)
                     (equal (nth 1 dst)(nth 2 dst) 1e-6)
                     )
                 (text-draw "ТРЕУГОЛЬНИК РАВНОБЕДРЕННЫЙ" pt (getvar "TEXTSIZE") 0 "_M")
                 )
                ((and (setq dst (get-angle-between-side lst))  ;_ Список углов между сторонами
                      (apply 'or (mapcar '(lambda(x)(equal x (* pi 0.5) 1e-6)) dst))
                      )
                      (text-draw "ТРЕУГОЛЬНИК ПРЯМОУГОЛЬНЫЙ" pt (getvar "TEXTSIZE") 0 "_M")
                 ) 
                (t (text-draw "ТРЕУГОЛЬНИК" pt (getvar "TEXTSIZE") 0 "_M"))
                )
            )
          
;;; Может это круг?
;;; У полилинии 2 дуговых сегмента
;;; кривизна дуговых сегментов (поле 42) будет постоянна и равна 1
     ((and (setq lst (massoc 42 (entget en)))
           (= (length lst) 2)
           (apply '= lst)
      ) ;_ end of and
      (text-draw "КРУГ" pt (getvar "TEXTSIZE") 0 "_M")
     )
     (t (alert "Не обрабатываемый контур"))
       ) ;_ end of cond
       (if (and en (entget en))
     (entdel en)
       ) ;_ end of if
      )
      (t
       (if (and en (not (equal en el)) (entget en))
     (entdel en)
       ) ;_ end of if
       (alert "Не обрабатываемый контур")
      )
    ) ;_ end of cond
  ) ;_ end of while
) ;_ end of defun
;;;Дополнительные функции
(defun get-angle-between-side ( lst / dst )
  ;;; Список углов между сторонами
  ;;;  lst - Список координат вершин многоугольника
  
                        (mapcar '(lambda(x y)
                           (3d_angw1w2 x y)
                         )
                         (append
                            (setq dst  ;;;Вектора  
                              (mapcar '(lambda(x y)
                                (mapcar '- x y)
                                  ;(cons x (list y))
                                 )  
                                (append lst (list(car lst))) (cdr (append lst (list(car lst))))
                            )
                        )
                       (list (car dst))
                     )
                  (cdr (append dst (list (car dst))))
                  )
            )
  

(defun text-draw (txt pnt height rotation justification)
;;;Ф-ция отрисовывает текст txt
;;; в точке pnt
;;; высотой heigth
;;; углом повотора rotation
;;; выравниванием justification
  (if (null pnt)
    (vl-cmdf "_.-TEXT" "" txt)
    (if    (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))
       0.0
    ) ;_ end of =
      (progn
    ;; нулевая высота текста
    (if justification
      (vl-cmdf "_.-TEXT"   "_J"       justification
           "_non"      pnt       height      rotation
           txt
          ) ;_ end of vl-cmdf
      (vl-cmdf "_.-TEXT" "_non" pnt height rotation txt)
    ) ;_ end of if
      ) ;_ end of progn
      (progn
    ;; фиксированнная высота
    (if justification
      (vl-cmdf "_.-TEXT" "_J" justification    "_non" pnt rotation txt) ;_ end of vl-cmdf
 ;_ end ofvl-cmdf
      (vl-cmdf "_.-TEXT" "_non" pnt rotation txt)
    ) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end ofif
  (entlast)
) ;_ end ofdefun

(defun massoc (key alist / x nlist)
;;; Возвращает все вхождения ключа в списке
;;; ! Argument : 'key'     - DXF код
;;; !            'alist' -    Список
;;; ! Returns  : Список всех значений ключа key, если есть или nil

  (foreach x alist
    (if    (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
    ) ;_ end of if
  ) ;_ end offoreach
  (reverse nlist)
) ;_ end of defun

(defun 3d_angw1w2 (Wekt1 Wekt2 / CosA)
;;; Угол между векторами (скалярное произведение векторов)
;;;--------------------------------------------------------
;;; Параметры:
;;; Wekt1, Wekt2 - вектора
;;; Возвращает  угол между векторами в радианах
;;; http://www.elecran.com.ua/index.php?pagename=programer.php
;;;--------------------------------------------------------
  (if (equal (setq CosA    (/ (apply '+ (mapcar '* Wekt1 Wekt2))
               (distance '(0 0 0) Wekt1)
               (distance '(0 0 0) Wekt2)
            ) ;_ end of
         ) ;_ end of setq
         -1.0
         1e-6
      ) ;_ end of equal
    Pi
    (if    (equal CosA 0.0 1e-6)
      (* 0.5 PI)
      (atan (sqrt (- 1 (* CosA CosA))) CosA)
    ) ;_ end of if
  ) ;_ end of if
) ;_ end of defun
(defun parallelp (p1 p2 p3 p4)
;;; PARALLELP
;;; Высисляет, параллелен ли сегмент
;;; заданный точками p1 p2 сегменту, заданному точками p3 p4
;;;
;;; Аргумент = 4 точки

  (and
    (not (inters p1 p2 p3 p4 nil))
    (or    (inters p1 p4 p3 p2 nil)
    (inters p1 p3 p4 p2 nil)
    ) ;_ end of or
  ) ;_ end of and
) ;_ end of defun