I want to change the ARC for Revcloud so I used 2 Subroutine
- IsRevcloud to check if the object revcloud or no
- PSimple to remove unneeded vertex
The lisp working fine for one object, but REPEAT not working.
; q_|_|| _\|| q_|| _\| ;
; Mainroutine Start ;
(Defun c:dr ( / )
(setq scl 125 )
(setq Reversedirection "NO")
(setq i -1)
(if (setq s (ssget '((0 . "*LINE"))))
(progn
(repeat (sslength s)
(setq e (ssname s (setq i (1+ i))))
(if (IsRevcloud e)
(progn
(setq en (entget e)
en (subst '(42 . 0) (assoc 42 en) en) )
(setq e (entmod en))
(setq en (cdr (car e)))
(setq enn (PSimple en))
(command "REVCLOUD" "ARC" scl scl "Object" en Reversedirection)
)
)
)
)
)
)
; q_|_|| _\|| q_|| _\| ;
; Mainroutine End ;
; q_|_|| _\|| q_|| _\| ;
; Subroutine Start ;
;;;=======================[ PSimple.lsp ]=======================
;;; Author: Charles Alan Butler
;;; Version: 1.7 Nov. 23, 2007
;;; Purpose: To remove unnecessary vertex from a pline
;;; Supports arcs and varying widths
;;;=============================================================
;; This version will remove the first vertex if it is colinear
;; and first & last arcs that have the same center
;; Open plines that have the same start & end point will be closed
;; Argument: et
;; may be an ename, Vla-Object, list of enames or
;; a selection set
;; Returns: a list, (ename message)
;; Massage is number of vertex removed or error message string
;; If a list or selection set a list of lists is returned
(defun PSimple (et / doc result Tan Replace BulgeCenter RemoveNlst ps1)
(vl-load-com)
(defun tan (a) (/ (sin a) (cos a)))
(defun replace (lst i itm)
(setq i (1+ i))
(mapcar '(lambda (x) (if (zerop (setq i (1- i))) itm x)) lst)
)
;; CAB 11.16.07
;; Remove based on pointer list
(defun RemoveNlst (nlst lst)
(setq i -1)
(vl-remove-if '(lambda (x) (not (null (vl-position (setq i (1+ i)) nlst)))) lst)
)
(defun BulgeCenter (bulge p1 p2 / delta chord radius center)
(setq delta (* (atan bulge) 4)
chord (distance p1 p2)
radius (/ chord (sin (/ delta 2)) 2)
center (polar p1 (+ (angle p1 p2) (/ (- pi delta) 2)) radius)
)
)
;; Main function to remove vertex
;; ent must be an ename of a LWPolyline
(defun ps1 (ent / aa cpt dir doc elst hlst Remove
idx keep len newb result vlst x closed
d10 d40 d41 d42 hlst p1 p2 p3
plast msg)
;;=====================================================
(setq elst (entget ent)
msg "")
(setq d10 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) elst)))
(if (> (length d10) 2)
(progn
;; seperate vertex data
(setq d40 (vl-remove-if-not '(lambda (x) (= (car x) 40)) elst))
(setq d41 (vl-remove-if-not '(lambda (x) (= (car x) 41)) elst))
(setq d42 (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) elst)))
;; remove extra vertex from point list
(setq plast (1- (length d10)))
(setq p1 0 p2 1 p3 2)
(if (and (not (setq closed (vlax-curve-isclosed ent)))
(equal (car d10) (last d10) 1e-6))
(progn
(setq Closed t ; close the pline
elst (subst (cons 70 (1+(cdr(assoc 70 elst))))(assoc 70 elst) elst)
msg " Closed and")
(if (and (not(zerop (nth plast d42)))(not(zerop (nth 0 d42))))
(setq d10 (reverse(cdr(reverse d10)))
d40 (reverse(cdr(reverse d40)))
d41 (reverse(cdr(reverse d41)))
d42 (reverse(cdr(reverse d42)))
plast (1- plast)
)
)
)
)
(setq idx -1)
(while (<= (setq idx (1+ idx)) (if closed (+ plast 2) (- plast 2)))
(cond
((and (or (equal (angle (nth p1 d10) (nth p2 d10))
(angle (nth p2 d10) (nth p3 d10)) 1e-6)
(equal (nth p1 d10) (nth p2 d10) 1e-6)
(equal (nth p2 d10) (nth p3 d10) 1e-6))
(zerop (nth p2 d42))
(or (= p1 plast)
(zerop (nth p1 d42)))
)
(setq remove (cons p2 remove)) ; build a pointer list
(setq p2 (if (= p2 plast) 0 (1+ p2))
p3 (if (= p3 plast) 0 (1+ p3))
)
)
((and (not (zerop (nth p2 d42)))
(or closed (/= p1 plast))
(not (zerop (nth p1 d42))) ; got two arcs
(equal
(setq cpt (BulgeCenter (nth p1 d42) (nth p1 d10) (nth p2 d10)))
(BulgeCenter (nth p2 d42) (nth p2 d10) (nth p3 d10))
1e-4)
)
;; combine the arcs
(setq aa (+ (* 4 (atan (abs (nth p1 d42))))(* 4 (atan (abs (nth p2 d42)))))
newb (tan (/ aa 4.0))
)
(if (minusp (nth p1 d42))
(setq newb (- (abs newb)))
(setq newb (abs newb))
)
(setq remove (cons p2 remove)) ; build a pointer list
(setq d42 (replace d42 p1 newb))
(setq p2 (if (= p2 plast) 0 (1+ p2))
p3 (if (= p3 plast) 0 (1+ p3))
)
)
(t
(setq p1 p2
p2 (if (= p2 plast) 0 (1+ p2))
p3 (if (= p3 plast) 0 (1+ p3))
)
)
)
)
(if remove
(progn
(setq count (length d10))
;; Rebuild the vertex data with pt, start & end width, bulge
(setq d10 (RemoveNlst remove d10)
d40 (RemoveNlst remove d40)
d41 (RemoveNlst remove d41)
d42 (RemoveNlst remove d42)
)
(setq result (mapcar '(lambda(w x y z) (list(cons 10 w)
x y
(cons 42 z))) d10 d40 d41 d42)
)
;; rebuild the entity data with new vertex data
(setq hlst (vl-remove-if
'(lambda (x) (vl-position (car x) '(40 41 42 10))) elst)
)
(mapcar '(lambda (x) (setq hlst (append hlst x))) result)
(setq hlst (subst (cons 90 (length result)) (assoc 90 hlst) hlst))
(if (entmod hlst); return ename and number of vertex removed
(list ent (strcat msg " Vertex removed " (itoa(- count (length d10)))))
(list ent " Error, may be on locked layer.")
)
)
(list ent "Nothing to remove - no colenier vertex.")
)
)
(list ent "Nothing to do - Only two vertex.")
)
)
;; ======== S T A R T H E R E ===========
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(cond
((or (=(type et) 'ENAME)
(and (=(type et) 'VLA-object)
(setq et (vlax-vla-object->ename et))))
(vla-startundomark doc)
(setq result (ps1 et))
(vla-endundomark doc)
)
((= (type et) 'PICKSET)
(vla-startundomark doc)
(setq result (mapcar '(lambda(x) (ps1 x))
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
(vla-endundomark doc)
)
((listp et)
(vla-startundomark doc)
(setq result (mapcar '(lambda(x) (ps1 x)) et))
(vla-endundomark doc)
)
((setq result "PSimple Error - Wrong Data Type."))
)
result
)
(prompt "\nPline Simplify loaded, PSimple to run.")
(princ)
;| ====== IsRevClode ==========
* EN
* Function defines, whether draw a polyline a command _Revcloud
* the Polyline is considered Revcloud if:
1. It LW a polyline
2. All segments of a polyline arc
3. Coordinates of the centers of these segments do not coincide
4. Curvature of arc segments is identical as on a sign, and numerically
Arguments:
pl - a name (ENAME) or object (VLA-OBJECT) polylines
Return:
T - if a polyline satisfies to the listed conditions
nil - in all other cases
Example of use
(IsRevcloud (car (entsel)))
* RUS
* ??????? ??????????, ?????????? ?? ????????? ???????? _Revcloud
* ????????? ????????? ???????????? ???????? _Revcloud ????:
1. ??? LW ?????????
2. ??? ???????? ????????? ???????
3. ?????????? ??????? ???? ????????? ?? ?????????
4. ???????? ??????? ????????? ????????? ??? ?? ?????, ??? ? ????????
?????????:
pl - ??? (ENAME) ??? ?????? (VLA-OBJECT) ?????????
???????:
T - ???? ????????? ????????????? ????????????? ????????
nil - ?? ???? ?????? ???????
?????? ?????????????
(IsRevcloud (car(entsel)))
|;
(defun IsRevcloud ( pl / st-en-bulge->center ed crs bulge_list bulge_log center)
;| EN
Helper function st-en-bulge-> center
* the Author the Pastuh
* It is published: http://www.autocad.ru/cgi-bin/f1/board.cgi?t=37164rO
* Purpose
* Receives coordinates of the center of the arch set by points of the beginning, the end and size bulge.
* thus, position of a point of the center is defined so that detour of initial, final points of an arch and
* the received point of the center occured in a direction counter-clockwise.
Arguments:
Point [list] - a point of the beginning of a segment
p2 = Point [list] - a point of the end of a segment
st - Point [list] - a bidimentional point of the beginning of an arch,
en - Point [list] - a bidimentional point of the end of an arch,
bulg - a tangent 1/4 central corners of an arch (bulge).
Return:
Bidimentional coordinates of a point of the center.
nil if points of the beginning and the end of an arch coincide.
nil if camber is set equal to zero.
|;
;| RUS
?????????????? ?-??? st-en-bulge->center
* ????? ??????
* ????????????: http://www.autocad.ru/cgi-bin/f1/board.cgi?t=37164rO
* ??????????
* ???????? ?????????? ?????? ????, ???????? ??????? ??????, ????? ? ????????? ?????????? (bulge).
* ??? ????, ????????? ????? ?????? ???????????? ???, ????? ????? ?????????, ???????? ????? ???? ?
* ?????????? ????? ?????? ?????????? ? ??????????? ?????? ??????? ???????.
?????????:
Point[list] - ????? ?????? ????????
p2 = Point[list] - ????? ????? ????????
st - Point[list] - ????????? ????? ?????? ????,
en - Point[list] - ????????? ????? ????? ????,
bulg - ??????? 1/4 ???????????? ???? ???? (bulge).
???????:
????????? ?????????? ????? ??????.
nil, ???? ????????? ????? ?????? ? ????? ????.
nil, ???? ?????????? ?????? ?????? ????.
|;
(defun st-en-bulge->center (st
en
bulg
/
a sina cosa 1-cosa
b1 b2
d d1 d2
)
(setq a (* (atan bulg) 4.0) sina (sin a) cosa (cos a) 1-cosa (- 1 cosa))
(cond
((equal st en 1e-12) nil);
((equal 1-cosa 0.0 1e-12) nil);
(T
(setq b1 (+ (- (car en) (* (car st) cosa)) (* (cadr st) sina))
b2 (- (cadr en) (* (car st) sina) (* (cadr st) cosa))
d (* 2 1-cosa)
d1 (- (* b1 1-cosa) (* b2 sina))
d2 (+ (* b2 1-cosa) (* b1 sina))
);
(list (/ d1 d) (/ d2 d));
);
); end cond.
); end defun.
(and
(if (eq (type pl) 'VLA-OBJECT)
(setq pl (vlax-vla-object->ename pl))
pl
)
(wcmatch (cdr(assoc 0 (setq ed (entget pl)))) "LWPOLYLINE")
(setq ed (entget pl))
(setq crs (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= 10 (car x)))) ed)))
(setq bulge_list (mapcar 'cdr (vl-remove-if-not '(lambda(x)(= (car x) 42)) ed)))
(if (= (logand (cdr(assoc 70 ed)) 1) 1)
(setq crs (append crs (list (car crs))))
(setq bulge_list (reverse(cdr(reverse bulge_list)))) ;_???? ?? ????????? ??????, ??????? ????????? bulge
;_If not closed PLINE, we delete last bulge
)
(setq bulge_log (mapcar 'zerop bulge_list))
(not(apply 'or bulge_log)) ;_??? ??????? ????????
;_All arc segments
(apply 'and (mapcar '(lambda(x)(equal x (car bulge_list) 1e-6)) bulge_list)) ;_????? ???????? ??? (??????? 1/4 ????)
;_ Equal curvature of arches (the Tangent 1/4 corners)
(setq center (mapcar '(lambda(st pl blg)(st-en-bulge->center st pl blg)) crs (cdr crs) bulge_list))
(not (apply 'and (mapcar '(lambda(x)(equal x (car center) 1e-6)) center))) ;_?????? ???. ????????? ?? ?????????
;_ The centers of arc segments do not coincide
)
)
; q_|_|| _\|| q_|| _\| ;
; Subroutine End ;