Topic: Delete arcs from pline - lisp request

[ribarm]

Here you are... Just make sure start and end segments are straight... And you have to have at least single straight between arced segments...

Code - Auto/Visual Lisp: [Select]

1. ;; Decurve  -  Lee Mac
2. ;; Equivalent to applying a zero-radius fillet to a polyline with arc-segments
3.  
4. (defun c:decurve ( / ptonline lwv-ptb LM:BulgeRadius unique k enx hed idx int lst ocs rtn sel )
5.  
6.     (defun ptonline ( pt1 pt2 pt3 )
7.         (equal (distance pt1 pt3) (+ (distance pt1 pt2) (distance pt2 pt3)) 1e-8)
8.     )
9.  
10.     (defun lwv-ptb ( lst )
11.         (if (setq lst (member (assoc 10 lst) lst))
12.             (cons (list (assoc 10 lst) (assoc 42 lst)) (lwv-ptb (cdr lst)))
13.         )
14.     )
15.  
16.     ;; Bulge Radius  -  Lee Mac
17.     ;; p1 - start vertex
18.     ;; p2 - end vertex
19.     ;; b  - bulge
20.     ;; Returns the radius of the arc described by the given bulge and vertices
21.  
22.     (defun LM:BulgeRadius ( p1 p2 b )
23.         (/ (* (distance p1 p2) (1+ (* b b))) 4 (abs b))
24.     )
25.  
26.     (defun unique ( lst / a ll )
27.         (while (setq a (car lst))
28.             (if (vl-some (function (lambda ( x ) (equal x a 1e-6))) (cdr lst))
29.                 (setq ll (cons a ll) lst (vl-remove-if (function (lambda ( x ) (equal x a 1e-6))) (cdr lst)))
30.                 (setq ll (cons a ll) lst (cdr lst))
31.             )
32.         )
33.         (reverse ll)
34.     )
35.  
36.     (while (= 8 (logand 8 (getvar 'undoctl)))
37.         (vl-cmdf "_.undo" "_e")
38.     )
39.     (vl-cmdf "_.undo" "_be")
40.     (if (and
41.             (setq sel (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "<NOT") (-4 . "&=") (70 . 1) (-4 . "NOT>"))))
42.             (not (initget 7))
43.             (setq rad (getdist "\nPick or specify top radius of curving to preserve curvature : "))
44.         )
45.         (repeat (setq idx (sslength sel))
46.             (setq enx (entget (ssname sel (setq idx (1- idx))))
47.                   hed (reverse (member (assoc 38 enx) (reverse enx)))
48.                   ocs (cdr (assoc 210 enx))
49.                   lst nil
50.                   lst (lwv-ptb enx)
51.                   rtn nil
52.             )
53.             (setq k -1)
54.             (foreach x lst
55.                 (setq k (1+ k))
56.                 (cond
57.                     (   (equal 0.0 (cdr (assoc 42 x)) 1e-8)
58.                         (setq rtn (cons x rtn))
59.                     )
60.                     (   t
61.                         (if (> (LM:BulgeRadius (cdr (car (nth k lst))) (cdr (car (nth (1+ k) lst))) (cdr (cadr (nth k lst)))) rad)
62.                             (if (<= (+ k 2) (1- (length lst)))
63.                                 (progn
64.                                     (setq int (inters (cdr (car (nth (1- k) lst))) (cdr (car (nth k lst))) (cdr (car (nth (1+ k) lst))) (cdr (car (nth (+ 2 k) lst))) nil))
65.                                     (setq rtn (cons (list (cons 10 (cdr (car (nth k lst)))) (cons 42 0.0)) rtn))
66.                                     (setq rtn (cons (list (cons 10 int) (cons 42 0.0)) rtn))
67.                                     (setq rtn (cons (list (cons 10 (cdr (car (nth (1+ k) lst)))) (cons 42 0.0)) rtn))
68.                                 )
69.                             )
70.                             (setq rtn (cons x rtn))
71.                         )
72.                     )
73.                 )
74.             )
75.             (setq rtn (unique rtn))
76.             (if (entmake
77.                     (append
78.                         (subst (cons 90 (length rtn)) (assoc 90 hed) hed)
79.                         (apply 'append (reverse rtn))
80.                         (list (cons 210 ocs))
81.                     )
82.                 )
83.                 (entdel (cdr (assoc -1 enx)))
84.             )
85.         )
86.     )
87.     (vl-cmdf "_.undo" "_e")
88.     (princ)
89. )
90.  

HTH.
M.R.