I have trouble with this routine I coded recently... This question was asked before, but I and others didn't wanted to answer as question was delicate and by solving result should be very similar to original source entity in question - LWPOLYLINE with / without arced segments...
In attachment is my DWG I quickly created with one of my PLINETOOLS archive and desired solution for this problem is already there., i.e. I created green lwpolyline from white on right side and my goal is that now I am trying to create white from green on the left side... Green lwpolyline has many unnecessary vertices, and so I coded for making diet polyline with only those vertices that are in white lwpolyline... You'll see all in DWG when you download it...
Sadly my code is going in endless (while) loops from 2 sub functions contained in routine named (group_*)...
Can someone try to fix and find where is the problem as I think that those subs are needed for this routine...
(defun c:dietpl ( / vertlst bulglst collinear-p group_collinear_pts group_fuzz_pts mid acos tang clockwise-p s fuzz lw ptlst blst assoclst gg g p1 p2 p3 mp1 mp2 c r d ang b nlw lwx )
(defun vertlst ( lw )
(mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget lw)))
)
(defun bulglst ( lw )
(mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 42))) (entget lw)))
)
(defun collinear-p ( p1 p p2 )
(equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
)
(defun group_collinear_pts ( ptlst / a b c g gg )
(while ptlst
(setq a (car ptlst) b (cadr ptlst) c (caddr ptlst))
(while (and c (collinear-p a b c))
(if (not (vl-position a g))
(setq g (cons a g))
)
(if (not (vl-position b g))
(setq g (cons b g))
)
(if (not (vl-position c g))
(setq g (cons c g))
)
(setq ptlst (cdr ptlst))
)
(setq ptlst (cdr ptlst))
(setq gg (cons (reverse g) gg))
(setq g nil)
)
(reverse gg)
)
(defun group_fuzz_pts ( ptlst fuzz / a b g gg )
(while ptlst
(setq a (car ptlst) b (cadr ptlst))
(while (and b (< (distance a b) fuzz))
(if (not (vl-position a g))
(setq g (cons a g))
)
(if (not (vl-position b g))
(setq g (cons b g))
)
(setq ptlst (cdr ptlst))
)
(setq ptlst (cdr ptlst))
(setq gg (cons (reverse g) gg))
(setq g nil)
)
(reverse gg)
)
(defun mid ( p1 p2 )
(mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
)
(defun acos ( x )
(cond
( (equal x 1.0 1e-8) 0.0 )
( (equal x -1.0 1e-8) pi )
( (and
(>= x 0.0)
(equal x 0.0 1e-8)
)
(/ pi 2.0)
)
( (and
(<= x 0.0)
(equal x -0.0 1e-8)
)
(* 3.0 (/ pi 2.0))
)
( t
(atan (sqrt (- 1.0 (* x x))) x)
)
)
)
(defun tang ( a )
(/ (sin a) (cos a))
)
(defun clockwise-p ( p1 p p2 )
(minusp (- (* (car (mapcar (function -) p1 p)) (cadr (mapcar (function -) p2 p))) (* (cadr (mapcar (function -) p1 p)) (car (mapcar (function -) p2 p)))))
)
(prompt "\nPick LWPOLYLINE to make it with diet...")
(if
(and
(setq s (ssget "_+.:E:S" (list (cons 0 "LWPOLYLINE"))))
(not (initget 7))
(setq fuzz (getdist "\nPick or specify fuzz distance : "))
)
(progn
(setq lw (ssname s 0))
(setq ptlst (vertlst lw))
(setq blst (bulglst lw))
(setq assoclst (mapcar (function (lambda ( p b ) (cons p b))) ptlst blst))
(setq gg (group_collinear_pts ptlst))
(foreach g gg
(setq g (cdr g) g (reverse (cdr (reverse g))))
(foreach p g
(setq assoclst (vl-remove-if (function (lambda ( x ) (equal p (car x) 1e-6))) assoclst))
)
)
(setq gg (group_fuzz_pts ptlst fuzz))
(foreach g gg
(setq p1 (car g) p2 (cadr g) p3 (last g))
(setq mp1 (mid p1 p2) mp2 (mid p2 p3))
(setq c (inters mp1 (polar mp1 (+ (angle p1 p2) (* 0.5 pi)) 1.0) mp2 (polar mp2 (+ (angle p2 p3) (* 0.5 pi)) 1.0) nil))
(setq r (distance c p1))
(setq d (distance (mid p1 p3) c))
(setq ang (* 2.0 (acos (/ d r))))
(setq b (tang (/ ang 4.0)))
(if (clockwise-p p1 c p3)
(setq b (- b))
)
(setq assoclst (subst (cons (car g) b) (vl-some (function (lambda ( x ) (if (equal (car x) (car g) 1e-6) x))) assoclst) assoclst))
(setq g (cdr g) g (reverse (cdr (reverse g))))
(foreach p g
(setq assoclst (vl-remove-if (function (lambda ( x ) (equal p (car x) 1e-6))) assoclst))
)
)
(setq nlw
(entmakex
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length assoclst))
(assoc 70 (setq lwx (entget lw)))
(assoc 38 lwx)
)
(apply (function append) (mapcar (function (lambda ( p b ) (list (cons 10 p) (cons 42 b)))) (mapcar (function car) assoclst) (mapcar (function cdr) assoclst)))
(list (assoc 210 lwx))
)
)
)
)
)
(princ)
)
Regards, M.R.