[Shoorup]

Итак имеем несколько окружностей произвольного диаметра. Например 17,24,36,17мм Необходимо разместить эти окружности вплотную так, чтобы описанная окружность вокруг них была минимального диаметра. Этот диаметр и нужно вычислить. Окружности могут располагаться на плоскости произвольно.
Задачка явно школьная но у меня чего-то на ум ничего не приходит как такое можно вычислить.

[dyr]

Сообщение от Li6-D Соглашусь с zamtmn, что указанный способ не верен даже для варианта касающихся друг друга трех окружностей. Задача о нахождении окружности касательной к трем другим (не обязательно касательных между собой) решается при помощи построений и без всякой алгебры. Автор геометрического решения - Апполоний Пергский, знакомьтесь.

А где центр внешней окружности?

[Li6-D]

Сообщение от dyr А где центр внешней окружности?

Вот хоть плохенькое, но тем не менее решение на Лиспе (в духе сообщения Хмурого).
Вариант построения окружности (а их может быть до 8-ми) зависит от положения
прицела при выборе объектов:

Код:

[Выделить все]

;;;Команда строит окружность, касающуюся трех выбираемых пользователем
;;;объектов вида: окружность, отрезок (луч, прямая) или точка.
(defun C:Apollonios (/ *error* txtn osmode cmdecho ent p cmds pc k entN)
  (defun *error* (msg)
    (setvar "OSMODE" osmode)
    (setvar "CMDECHO" cmdecho)
    (foreach ent entN (redraw ent 4))
    (princ (strcat "Чего-то не так... " msg))
    (princ)
  )
  (setq txtn '("первый" "второй" "третий")
        osmode (getvar "OSMODE")
        cmdecho (getvar "CMDECHO")
  )
  (setvar "OSMODE" 1024)
  (setvar "CMDECHO" 0)
  (repeat 3
    (while
      (not
        (cond
          ((not (setq ent (entsel (strcat "\nУкажите " (car txtn) " объект (окружность, линию, точку): "))))
            (exit))
          ((= (cdr (assoc 0 (setq P (cadr ent) ent (entget (car ent))))) "POINT")
            (setq cmds (cons (cdr (assoc 10 ent)) cmds))
          )
          ((= (cdr (assoc 0 ent)) "CIRCLE")
            (setq pc (cdr (assoc 10 ent))
                  k (/ (cdr (assoc 40 ent)) (distance pc p))
                  cmds (cons "_tan" (cons (mapcar '(lambda (c r) (+ c (* k (- r c)))) pc p) cmds))
          ) )
          ((= (cdr (assoc 0 ent)) "LINE")
            (setq pc (cdr (assoc 10 ent))
                  p (list (mapcar '- (cdr (assoc 11 ent)) pc) (mapcar '- p pc))
                  k (/ (apply '+ (mapcar '* (car p) (cadr p))) (apply '+ (mapcar '* (car p) (car p))))
                  cmds (cons "_tan" (cons (mapcar '(lambda (c r) (+ c (* k r))) pc (car p)) cmds))

          ) )
          ((vl-string-search (cdr (assoc 0 ent)) "RAY,XLINE")
            (setq pc (cdr (assoc 10 ent))
                  p (list (cdr (assoc 11 ent)) (mapcar '- p pc))
                  k (apply '+ (mapcar '* (car p) (cadr p)))
                  cmds (cons "_tan" (cons (mapcar '(lambda (c r) (+ c (* k r))) pc (car p)) cmds))

          ) )
          ((prompt "\nУказан не тот объект! Повторите выбор."))
    ) ) )
    (redraw (car (setq txtn (cdr txtn) entN (cons (cdar ent) entN))) 3)
  )
  (setq p (vl-remove "_tan" cmds))
  (vl-cmdf "_.ZOOM" "_W" (apply 'mapcar (cons 'min p)) (apply 'mapcar (cons 'max p)))
  (apply 'vl-cmdf (append '("_.CIRCLE" "_3P") cmds '("_.ZOOM" "_P")))
  (setvar "OSMODE" osmode)
  (setvar "CMDECHO" cmdecho)
  (foreach ent entN (redraw ent 4))
  (princ)
)

[Елпанов Евгений]

математическое решение...

Код:

[Выделить все]

(defun soddi_circle (e1 e2 e3 / A A1 B B1 C C1 D D1 R R1 R2 R3 X X1 X2 X3 Y Y1 Y2 Y3)
                    ;|
Elpanov Evgeniy
11.01.2011
для темы:
http://forum.dwg.ru/showthread.php?t=61878

Построение описанной окружности
вокруг трех касающихся окружностей
Работает только для случая, когда все три окружности будут касаться описанной!

алгоритм нахождения центра:
http://mathworld.wolfram.com/ApolloniusProblem.html
алгоритм нахождения радиуса:
http://mathworld.wolfram.com/SoddyCircles.html
Пример использования:
(defun c:test (/ E1 E2 E3)
 (if (and (setq e1 (car (entsel "\n Первая окружность")))
          (setq e2 (car (entsel "\n Вторая окружность")))
          (setq e3 (car (entsel "\n Третья окружность")))
     )
  (soddi_circle e1 e2 e3)
 )
 (princ)
)
|;
 (setq ;;Первая окружность
       x1 (cadr (assoc 10 (entget e1)))
       y1 (caddr (assoc 10 (entget e1)))
       r1 (cdr (assoc 40 (entget e1)))
       ;;Вторая окружность
       x2 (cadr (assoc 10 (entget e2)))
       y2 (caddr (assoc 10 (entget e2)))
       r2 (cdr (assoc 40 (entget e2)))
       ;;Третья окружность
       x3 (cadr (assoc 10 (entget e3)))
       y3 (caddr (assoc 10 (entget e3)))
       r3 (cdr (assoc 40 (entget e3)))
 )
 (setq a  (* 2. (- x1 x2))
       b  (* 2. (- y1 y2))
       c  (* 2. (- r2 r1))
       d  (+ (* x1 x1) (* y1 y1) (* r1 r1 -1) (* x2 x2 -1) (* y2 y2 -1) (* r2 r2))
       a1 (* 2. (- x1 x3))
       b1 (* 2. (- y1 y3))
       c1 (* 2. (- r3 r1))
       d1 (+ (* x1 x1) (* y1 y1) (* r1 r1 -1) (* x3 x3 -1) (* y3 y3 -1) (* r3 r3))
       r  (abs (/ (* r1 r2 r3)
                  (+ (* r1 r2) (* r1 r3) (* r2 r3) (* -2 (sqrt (* r1 r2 r3 (+ r1 r2 r3)))))
               )
          )
       x  (/ (+ (* b1 d) (* b d1 -1) (* b1 c r -1) (* b c1 r)) (- (* a b1) (* a1 b)))
       y  (/ (+ (* a1 d -1) (* a d1) (* a1 c r) (* a c1 r -1)) (- (* a b1) (* a1 b)))
 )
 (entmakex (list '(0 . "circle") (list 10 x y) (cons 40 r)))
)

[Дима_]

Offtop: (defun soddi_circle (e1 e2 e3 / A A1 B B1 C C1 D D1 R R1 R2 R3 X X1 X2 X3 Y Y1 Y2 Y3) - Евгений Вы меня пугаете

[Елпанов Евгений]

новая версия, обрабатывает все случаи построения минимальной описанной окружности вокруг трех, взаимно-касающихся и не вложенных окружностей.

Код:

[Выделить все]

(defun soddi_circle (a b c / A1 B1 C1 D D1 R R1 R2 R3 X1 X2 X3 Y1 Y2 Y3)
                    ;|
by
Elpanov Evgeniy

дата создания: 11.01.2011
последнее изменение: 12.01.2011
для темы: http://forum.dwg.ru/showthread.php?t=61878

Построение минимальной описанной окружности
вокруг трех взаимно-касающихся и не вложенных окружностей.

Обрабатывает оба возможных случая,
1. опсанная окружность касается только двух окружностей,
третья полностью внутри
2. описанная окружность касается всех трех окружностей.

алгоритм нахождения центра:
http://mathworld.wolfram.com/ApolloniusProblem.html
алгоритм нахождения радиуса:
http://mathworld.wolfram.com/SoddyCircles.html
Пример использования:
(defun c:test (/  a b c)
 (if (and (setq a (car (entsel "\n Первая окружность")))
          (setq b (car (entsel "\n Вторая окружность")))
          (setq c (car (entsel "\n Третья окружность")))
     )
  (soddi_circle a b c)
 )
 (princ)
)
|;
 (setq c  (vl-sort (mapcar (function (lambda (a) (cons (cdr (assoc 40 (entget a))) (entget a))))
                           (list a b c)
                   )
                   (function (lambda (a b) (>= (car a) (car b))))
          )
       r1 (caar c)
       a  (cdr (assoc 10 (cdar c)))
       r2 (caadr c)
       b  (cdr (assoc 10 (cdadr c)))
       r3 (caaddr c)
       c  (cdr (assoc 10 (cdaddr c)))
 )
 (if (> (setq r (/ (+ r1 r2 (distance a b)) 2.))
        (+ (distance (polar b (angle b a) r1) c) r3)
     )
  (entmakex (list '(0 . "circle") (cons 10 (polar a (angle a b) (- r r1))) (cons 40 r)))
  (progn
   (setq x1 (car a)
         y1 (cadr a)
         x2 (car b)
         y2 (cadr b)
         x3 (car c)
         y3 (cadr c)
         a  (* 2. (- x1 x2))
         b  (* 2. (- y1 y2))
         c  (* 2. (- r2 r1))
         d  (+ (* x1 x1) (* y1 y1) (* r1 r1 -1) (* x2 x2 -1) (* y2 y2 -1) (* r2 r2))
         a1 (* 2. (- x1 x3))
         b1 (* 2. (- y1 y3))
         c1 (* 2. (- r3 r1))
         d1 (+ (* x1 x1) (* y1 y1) (* r1 r1 -1) (* x3 x3 -1) (* y3 y3 -1) (* r3 r3))
         r  (abs (/ (* r1 r2 r3)
                    (+ (* r1 r2) (* r1 r3) (* r2 r3) (* -2 (sqrt (* r1 r2 r3 (+ r1 r2 r3)))))
                 )
            )
   )
   (entmakex
    (list '(0 . "circle")
          (list 10
                (/ (+ (* b1 d) (* b d1 -1) (* b1 c r -1) (* b c1 r)) (- (* a b1) (* a1 b)))
                (/ (+ (* a1 d -1) (* a d1) (* a1 c r) (* a c1 r -1)) (- (* a b1) (* a1 b)))
          )
          (cons 40 r)
    )
   )
  )
 )
)

[ucf]

Нашлась формула для оценки диаметра описывающего круга
D=(1.2...1.3)*sqrt(n)*d.
n - общее количество кругов (жил, проводников, труб);
d - среднее арифметическое значение всех диаметров.

Смотрите ГОСТ 23586-96
http://www.rgost.ru/index.php?option...2069&Itemid=39
или
http://www.complexdoc.ru/text/%D0%93...A2%2023586-96/
раздел - Б.3 Расчет диаметра жгута по формуле

[Li6-D]

Эта оценочная формула иногда может привести к парадоксальным результатам.
Например, есть одна окружность диаметром 1601 и 399 окружностей диаметром 1.
Среднее арифметическое значений диаметров: (1*1601+399*1)/400=5.
Диаметр описывающего круга по формуле: 1.3*sqrt(400)*5=130.
А на самом деле должен быть в диапазоне между 1602 и 1603.
Ошибка больше чем на порядок.

[kp+]

Посмотрите прогу "Канал 2007"
http://www.cleper.ru/programs/download/Channel.zip
Там и алгоритм хорошо описан.

Li6-D> все такого рода прикидочные формулы имеют границы применимости, задаваемые здравым смыслом и практикой

[Li6-D]

Сообщение от kp+ Li6-D> все такого рода прикидочные формулы имеют границы применимости, задаваемые здравым смыслом и практикой

Яйцеголовые бьются который век над плотнейшим заполнением одних фигур другими, книжки непонятные пишут, ГОСТ 23586-96 даже не читали.
А здравомыслящие и опытные люди посчитали и добавили свой лапоть.

[kp+]

Li6-D, ты за смайлик обиделся? Ну извини, я его уже убрал.

Сообщение от Li6-D Яйцеголовые бьются который век над плотнейшим заполнением одних фигур другими

Не спорю, плотнейшее заполнение - это тема нужная, например в приборостроении, проектировании печатных плат и микросхем.
Но оно неприменимо к прокладке кабелей, которые надо еще протащить в канале, далеко не всегда прямолинейном.

книжки непонятные пишут

Спасибо за ссылку

Сообщение от Li6-D ГОСТ 23586-96 даже не читали

В соответствии с тем, что написал автор темы в посте 6, здесь надо на другой документ ссылаться, "Инструкция по монтажу электропроводок в трубах"

Сообщение от Li6-D А здравомыслящие и опытные люди посчитали и добавили свой лапоть.

А то! Вот он, лапоть - новая версия программы Канал 2010. Респект Алексею Спиваку
http://alexeyspivak.narod.ru/

[Li6-D]

kp+, спасибо за информацию, эта программа многим пригодится.
А формулой можно пользоваться лишь в случае, если среднее арифметическое заменить средним квадратичным (если кабели разных диаметров, охватывающий диаметр увеличится со сравнению с формулой из ГОСТ).
Тогда коэффициент заполненности канала будет в диапазоне от 0.59 (1.3^-2) до 0.69 (1.2^-2).
Это довольно плотная укладка, для жгута пойдет, а для кабельного канала - нет. Не просто с ограничениями по применимости формулы: верхний предел заполненности не достижим для случаев укладки от 2 до 6 одинаковых кабелей, а нижний - для двух одинаковых кабелей.
Вывод
Не пользуйтесь этой формулой из ГОСТ. В данном случае простота хуже воровства. И помните о горькой судьбе блока космических аппаратов "Глонасс-М" №43, там виновата неправильная формула.

[VVA]

Еще одно решение от Lee Mac'a: минимальная окружность, описанная вокруг облака точек.
Minimum Enclosing Circle




http://en.wikipedia.org/wiki/Smallest_circle_problem

[Li6-D]

Позвольте бросить свой маленький грошик (< 1 kb) в эту копилку мудрости:

Код:

[Выделить все]

(defun Li6-D:MinC (pN / maxd cr2 cr3 c&p->c c0 c p)
;;Нахождение наименьшего  круга, содержащего точки из списка pN
  (defun maxd (c pN / d d0 p0)
    (setq d (car c) c (cdr c))
    (foreach p pN (if (> (setq d0 (distance c p)) d) (setq d d0 p0 p)))
    p0
  )
  (defun cr2 (p p0)
    (cons (/ (distance p p0) 2) (mapcar '(lambda (a b) (/ (+ a b) 2.)) p p0)))
  (defun cr3 (p p0 p1 / a r)
    (setq a (- (angle p1 p) (angle p1 p0)) r (/ (distance p p0) (sin a) 2))
    (cons (abs r) (polar p (+ (angle p0 p) (/ Pi 2) a) r))
  )
  (defun c&p->c (c0 p0 / p p1)
    (if (setq p (maxd (cons 0 p0) c0) p1 (maxd (cr2 p p0) (vl-remove p c0)))
      (list p p0 p1)
      (list p p0)
  ) )
  (and
    pN
    (car (setq c0 (cons 0 (car pN)) c (list (maxd c0 (cdr pN)) (cdr c0))))
    (while (setq c0 (apply (if (cddr c) 'cr3 'cr2) c)
                 p (maxd c0 (vl-remove-if '(lambda (a) (member a c)) pN)))
      (setq c (c&p->c c p))
  ) )
  c0
)

Кто сомневается, прошу протестировать:

Код:

[Выделить все]

(defun C:test ( / ss->pN c)
;;Рисует окружность (красного цвета) вокруг облака выбранных точек и отрезков
  (defun ss->pN (/ ss i p pN)
  ;;Выбор точек и отрезков, формирование списка точек pN
    (repeat (if (setq ss (ssget '((0 . "LINE,POINT")))) (setq i (sslength ss)) 0)
      (setq i (1- i)
            p (entget (ssname ss i))
            pN (cons (cdr (assoc 10 p)) pN)
      )
      (if (= (cdr (assoc 0 p)) "LINE") (setq pN (cons (cdr (assoc 11 p)) pN)))
    )
    pN
  )
  ;Определение и изображение минимальной окружности с помощью Li6-D:MinC
  (cond
    ((not (setq c (Li6-D:MinC (ss->pN)))) (alert "Точек нет"))
    ((zerop (car c)) (alert "Нет двух разных точек"))
    ((entmake
       (list
        '(0 . "CIRCLE")
         (cons 10 (cdr c))
         (cons 40 (car c))
        '(62 . 1)
) ) )) )

[Li6-D]

Для интересующихся выложил описание алгоритма Li6-D:MinC выше для нахождения радиуса и центра минимального круга, покрывающего несколько точек плоскости. Для сомневающихся - доказательство корректности (без формул!)
[IMG]http://s009.***********/i308/1201/9f/2cb9b45a207e.jpg[/IMG]

[Денис Флюстиков]

Не совсем в тему, но близко

Код:

[Выделить все]

 
;|=====================================================
Построение замкнутой полилинии минимальной длины вокруг выбранных объетов

Макрос для кнопки: 
^C^C^P(load "Around_Den");Around_Den
=====================================================|;

(defun C:Around_Den (/ *error* aa1 aa2 aa3 aa4 aa5 aa6 aa7 aa8)
  
(setq aa2 32						; Точность
      aa5 '("DIMENSION" "LEADER" "HATCH")		; Кроме объектов
      aa5 (mapcar '(lambda (q)(cons 0 (strcat "*" q))) aa5)
      aa5 (append '((-4 . "<NOT")(-4 . "<OR")) aa5 '((-4 . "OR>")(-4 . "NOT>")))
      aa3 (entlast)
      aa1 (ssadd)
      aa4 (ssget aa5))

(while (entnext aa3)
(setq aa3 (entnext aa3)))

(if aa4 (progn

(vl-load-com)

(vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))

(defun *error* (msg)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
(if (< (atof (getvar "ACADVER")) 17.1)
(vla-sendcommand (vla-get-activedocument
(vlax-get-acad-object)) "_.undo 1 ")
(command nil nil nil nil "_.undo" 1))
(setvar "CMDECHO" 1)
(princ "\nВыход во время обработки данных\n")
)

(princ "\nПодождите, выполняется обработка данных...\n")

(setvar "CMDECHO" 0)
(command "_.undo" "_m")
(setvar "OSMODE" 0)
(command "_.copy" aa4 "" "@" "@")

(while (entnext aa3)
(setq aa3 (entnext aa3)
      aa5 (vlax-ename->vla-object aa3)
      aa4 (cdr (assoc 0 (entget aa3))))

(if (wcmatch aa4 "~SEQEND")(progn

(if (= aa4 "POLYLINE")
(if (= (vla-get-Type aa5) 1)
(vla-put-Type aa5 2)))

(if (= aa4 "SPLINE")(progn

(setq aa4 0
      aa6 (vlax-curve-getEndParam aa5)
      aa7 (vlax-curve-getDistAtParam aa5 aa6)
      aa8 (* (vla-get-NumberOfControlPoints aa5) 20)
      aa6 (/ aa7 aa8))

(repeat (fix aa8)
(entmake (list '(0 . "POINT")(cons 10 (vlax-curve-getpointatdist aa5 aa4))))
(setq aa4 (+ aa4 aa6))
)  
(entmake (list '(0 . "POINT")(cons 10 (vlax-curve-getEndPoint aa5))))
)
(if (wcmatch aa4 "INSERT,MTEXT")
(command "_.explode" aa3)
(progn
(setq aa1 (ssadd aa3 aa1))
(vla-put-Visible aa5 :vlax-false)
)))
))
)

(setq aa6 0
      aa8 (/ 90.0 aa2)
      aa7 '())

(repeat aa2

(setq aa2 0
      aa6 (+ aa6 aa8)
      aa3 nil)

(command "_.rotate" aa1 "" '(0 0 0) aa8)

(repeat (sslength aa1)

(vla-GetBoundingBox (vlax-ename->vla-object (ssname aa1 aa2)) 'aa4 'aa5)

(setq aa4 (trans (vlax-safearray->list aa4) 0 1)
      aa5 (trans (vlax-safearray->list aa5) 0 1)
      aa2 (1+ aa2))

(if aa3
(setq aa3 (list (mapcar 'min aa4 (car aa3))(mapcar 'max aa5 (cadr aa3))))
(setq aa3 (list aa4 aa5))
)
)

(setq aa5 (* (/ aa6 180) pi)
      aa4 (list (car aa3)(list (caar aa3)(cadadr aa3))(cadr aa3)(list (caadr aa3)(cadar aa3))(car aa3))
      aa4 (mapcar '(lambda (q)(polar '(0 0 0) (- (angle '(0 0 0) q) aa5)(distance '(0 0 0) q))) aa4)
      aa7 (cons (reverse aa4) aa7))
)

(command "_.undo" "_b")

(setq aa1 '()
      aa2 0
      aa3 '())

(repeat 4
(mapcar '(lambda (q)(setq aa1 (cons (list (nth aa2 q)(nth (1+ aa2) q)) aa1))) aa7)
(setq aa2 (1+ aa2))
)

(setq aa1 (mapcar '(lambda (q u)(trans (inters (car q)(cadr q)(car u)(cadr u)) 1 0)) aa1 (cons (last aa1) aa1))
      aa4 (- (length aa1) 2))

(while (> aa4 2)
(setq aa4 (1- aa4))
(if (and (equal (nth (- aa4 2) aa1)(nth (- aa4 1) aa1) 1e-9)
	 (not (equal (nth aa4 aa1)(nth (- aa4 1) aa1) 1e-9))
	 (equal (nth (+ aa4 2) aa1)(nth (+ aa4 1) aa1) 1e-9))
(setq aa1 (vl-remove (nth aa4 aa1) aa1))
))

(mapcar '(lambda (q u)(if (not (equal q u 1e-9))(setq aa3 (cons (cons 10 q) aa3)))) aa1 (cons (last aa1) aa1))

(setq aa2 (list
	   '(0 . "LWPOLYLINE")
	   '(100 . "AcDbEntity")
	   '(100 . "AcDbPolyline")
	   (cons 90 (length aa3))
	   '(70 . 1))
      aa2 (append aa2 aa3))

(if (entmake aa2)(sssetfirst nil (ssadd (entlast) (ssadd))))

(setvar "CMDECHO" 1)
(vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))

))

(princ)
)

[Li6-D]

Небольшая прога для решения задачи Аполлония:

Код:

[Выделить все]

 (defun Li6-D:Apoll (a b c / f e d)
;;Функция возвращает список из пары кругов, касательных трем заданным кругам a, b, c.
;;Круг - это список, первый элемент которого радиус, остальные - координаты центра.
;;Радиусы могут быть отрицательными (при совпадении знаков будет внутреннее касание).
  (repeat 2
    (setq f e
          e (mapcar '- b a)
          d (apply '- (mapcar '* e e))
          e (mapcar '(lambda (x) (/ x d)) e)
          b c
  ) )
  (setq b '(0 0 0) e (mapcar '- f e) d (apply '- (mapcar '* e e)) c (angle b (cdr e)))
  (mapcar
   '(lambda (g) (setq d (apply '- (mapcar '* f g))) (mapcar '(lambda (k l) (+ k (/ l d 2))) a g))
    (if (minusp d)
      (list (cons 1 (polar b (+ c (setq d (angle b (list (car e) (sqrt (- d)))))) 1))
            (cons 1 (polar b (- c d) 1)))
) ) )

Не хотел усложнять код, поэтому остались нештатные ситуации когда:
1) два исходных круга касаются друг друга внутренним (внешним) образом, причем их радиусы одного (разного) знаков;
2) один искомый круг имеет нулевую кривизну, то есть вырождается в прямую.
В эти случаях, как правило, будет ошибка связанная с делением на нуль.

Пробничек:

Код:

[Выделить все]

 (defun C:test-Li6-D:Apoll (/ c cN color p)
;;Пример построения всех возможных кругов Аполлония, касающихся трех разных кругов или точек
  (foreach n '("пеpвой" "втоpой" "тpетьей")
    (while
      (or
        (prompt (strcat "\nВыбоp " n " круга или точки..."))
        (not (setq c (ssget "_:S" '((0 . "CIRCLE,POINT")))))
        (member (setq c (ssname c 0)) cN)
    ) )
    (setq cN (cons c cN))
  )
  (setq cN (mapcar
            '(lambda (c)
               (setq c (entget c) c (cons (cond ((cdr (assoc 40 c))) (0)) (cdr (assoc 10 c)))))
             (reverse cN)
           )
        color 1
  )
  (entmake (list '(0 . "BLOCK") '(2 . "*Unnn") (setq p (cons 10 (cdar cN))) '(70 . 1)))
  (repeat 4
    (foreach ap (print (apply 'Li6-D:Apoll cN))
      (entmake (list '(0 . "CIRCLE") (cons 10 (cdr ap)) (cons 40 (abs (car ap))) (cons 62 color))))
    (setq cN (list (cadr cN) (cons (- (caar cN)) (cdar cN)) (caddr cN)) color (1+ color))
  )
  (entmake (list '(0 . "INSERT") (cons 2 (entmake '((0 . "ENDBLK")))) p))
  (princ)
)