(defun pl:VxRdc ( pl tol / vx lst n ang i SL dH dS pt1 pt2 pt3 pt4 blg vect Remove vxucs etalon aa newb change_blg )
(setq pl (pl:conv-ent-to-ename pl))
;;;RUS: Исключаем сглаженные (Fit Spline) полилинии
;;;Замечен глюк, что если сразу сгладить полилинию, то
;;;dxf группа будет показывать на Polyline, а Объектная модель
;;;останется LWPOLYLINE с соответствующим вылетом
;;;EN We exclude smoothed (Fit Spline) polylines
(if (not (member (logand (cdr (assoc 70 (entget pl))) (+ 2 4)) '(2 4)))
(progn
(setq blg (pl-get-coors&width&bulge pl)
vx (nth 0 blg)
s_width (nth 1 blg)
e_width (nth 2 blg)
blg (nth 3 blg)
)
(setq vxucs (mapcar '(lambda(x)(trans x pl 1)) vx))
(setq n 1 len (length vx))
(setq pl (pl:conv-ent-to-vla pl))
(if (zerop (car blg))
(setq etalon (list (setq pt1 (nth 0 vxucs))
(setq pt2 (nth 1 vxucs))
(angle pt1 pt2)
(last (pl:3d_Wnorm pt1 pt2))
)
n 2
)
(setq etalon nil)
)
(while (< n len)
(grtext -1 (strcat "Вершина № "(itoa n)))
(cond
((equal (nth (1- n) vxucs)
(nth n vxucs)
1e-6
)
(setq Remove (cons (1- n) Remove))
)
;;;Дуга
((and
(< n (1- len))
(not (equal 0.0 (nth n blg) 1e-6)) ;_Current arc vertex
(not (equal 0.0 (nth (- n 1) blg) 1e-6)) ;_ Previous 1- arc vertex
(setq pt3 (BulgeCenterRadius
(nth (1- n) blg)
(trans (vlax-curve-getPointAtParam pl (1- n)) 0 1)
(trans (vlax-curve-getPointAtParam pl n) 0 1)
)
)
(setq pt4 (BulgeCenterRadius
(nth n blg)
(trans (vlax-curve-getPointAtParam pl n) 0 1)
(trans (vlax-curve-getPointAtParam pl (1+ n)) 0 1)
)
)
(equal (car pt3)(car pt4) 1e-6) ;_Equal Radius
(equal (cadr pt3)(cadr pt4) 1e-6) ;_Equal center
)
(setq etalon nil)
;; combine the arcs
(setq i (1- n))
(while (vl-position i Remove)(setq i (1- i))) ;;First not Removed vertex
(setq pt1 (if (setq aa (assoc i change_blg))
(cdr aa)
(nth i blg))
)
(setq aa (+ (* 4 (atan (abs pt1)))
(* 4 (atan (abs (nth n blg)))))
newb (tan (/ aa 4.0))
)
(if (minusp pt1)
(setq newb (- (abs newb)))
(setq newb (abs newb))
)
(if (setq aa (assoc i change_blg))
(setq change_blg (subst (cons i newb) aa change_blg))
(setq change_blg (cons (cons i newb) change_blg)))
(setq ;_ blg (pl:subst-i i newb blg)
Remove (cons n Remove)
)
)
((not (equal 0.0 (nth (- n 1) blg) 1e-6)) ;_ Previous 1- arc vertex
(setq etalon nil)
)
((equal 0.0 (nth (- n 1) blg) 1e-6) ;_Line
(if (null etalon)
(setq etalon (list (setq pt1 (nth (1- n) vxucs))
(setq pt2 (nth n vxucs))
(angle pt1 pt2)
(last (pl:3d_Wnorm pt1 pt2))
)
)
(progn
(setq pt1 (nth (1- n) vxucs)
pt2 (nth n vxucs)
SL (distance pt1 pt2)
ang (angle pt1 pt2)
vect (last (pl:3d_Wnorm pt1 pt2))
)
(if (apply 'equal (list (minusp vect)(minusp (last etalon)))) ;_Совпадают направления
(progn
(setq dS (if (< tol 0)(* (sin (abs tol)) SL) tol))
(setq
pt3 (polar pt2 (+ (nth 2 etalon)(* PI 0.5)) 1)
pt3 (inters pt2 pt3 (nth 0 etalon)(nth 1 etalon) nil))
(setq dH (if pt3 (distance pt2 pt3) 1.7e99))
(if (or
(equal pt1 pt2 1e-6) ;_Совпадают вершины
(equal dH dS 1e-6)
(<= dH dS) ;_Отклонение
)
(setq Remove (cons (1- n) Remove)) ;_Удаляем n-1 вершину
(setq etalon (list (setq pt1 (nth (1- n) vxucs))
(setq pt2 (nth n vxucs))
(angle pt1 pt2)
(last (pl:3d_Wnorm pt1 pt2))
)
)
)
)
(setq etalon (list (setq pt1 (nth (1- n) vxucs))
(setq pt2 (nth n vxucs))
(angle pt1 pt2)
(last (pl:3d_Wnorm pt1 pt2))
)
)
);_if
)
)
)
(t nil)
);_cond
(setq n (1+ n))
);_while < n len
;;;Обработать совпадания точек начала-конца. Если совпадают, то удалить последнюю и включить флаг замкнутости
(if (and (> (length vxucs) 3)
(equal (car vxucs)(last vxucs) 1e-6)
)
(progn
(setq Remove (cons (1- (length vxucs)) Remove))
(vla-put-Closed pl :vlax-true)
)
)
(setq i '-1 SL nil)
(if change_blg
(progn
(foreach bl blg
(if (setq aa (cdr(assoc (setq i (1+ i)) change_blg)))
(setq SL (cons aa SL))
(setq SL (cons bl SL))
)
)
(setq blg (reverse SL))
)
)
(if Remove
(progn
(setq vx (pl-RemoveNlst Remove vx))
(setq s_width (pl-RemoveNlst Remove s_width))
(setq e_width (pl-RemoveNlst Remove e_width))
(setq blg (pl-RemoveNlst Remove blg))
(PL-SET-COORS&WIDTH&BULGE pl vx s_width e_width blg)
)
)
)
)
(length Remove)
)
