Topic: Auto Arrange

[liuhaixin88]

This is similar to your 11.gif... It uses rotate&copy, but not mirror... Tested on simple LWPOLYLINES like on posted 11.gif...

Marko,I'd like to forward your code to “ bbs.mjtd.com” , I will keep the author's name, Do you agree?

[ribarm]

Look, similar to 1.png you posted... Also applicable only for LWPOLYLINE in WCS... You have to accept or hit ENTER if position isn't aligned as should...

Code - Auto/Visual Lisp: [Select]

1. (defun c:rotarrange-180 ( / adoc msp LM:MinEncCircle LM:RemoveWithFuzz LM:GetInsideAngle LM:3PCircle mid LM:ConvexHull LM:Clockwise-p LM:LWPoly->List pl n ri c minp maxp ar arl amin alst->amin bbox plc bbvl bbe bbc vx vy v ch )
2.  
3.   (vl-load-com)
4.   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
5.   (setq msp (vla-get-modelspace adoc))
6.  
7.   (defun LM:MinEncCircle ( lst / _sub )
8.  
9.       (defun _sub ( p1 p2 l1 / a1 a2 l2 p3 p4 )
10.           (setq l2 (LM:RemoveWithFuzz (list p1 p2) l1 1e-8)
11.                 p3 (car l2)
12.                 a1 (LM:GetInsideAngle p1 p3 p2)
13.           )
14.           (foreach p4 (cdr l2)
15.               (if (< (setq a2 (LM:GetInsideAngle p1 p4 p2)) a1)
16.                   (setq p3 p4 a1 a2)
17.               )
18.           )
19.           (cond
20.               (   (<= (/ pi 2.0) a1)
21.                   (list (mid p1 p2) (/ (distance p1 p2) 2.0))
22.               )
23.               (   (vl-some
24.                       (function
25.                           (lambda ( a b c )
26.                               (if (< (/ pi 2.0) (LM:GetInsideAngle a b c)) (_sub a c l1))
27.                           )
28.                       )
29.                       (list p1 p1 p2) (list p2 p3 p1) (list p3 p2 p3)
30.                   )
31.               )
32.               (   (LM:3PCircle p1 p2 p3)   )
33.           )
34.       )
35.  
36.       ((lambda ( lst ) (_sub (car lst) (cadr lst) lst)) (LM:ConvexHull lst))
37.   )
38.  
39.   ;; Remove With Fuzz  -  Lee Mac
40.   ;; Removes items from a list which are equal to a supplied tolerance
41.  
42.   (defun LM:RemoveWithFuzz ( l1 l2 fz )
43.       (vl-remove-if
44.           (function
45.               (lambda ( a )
46.                   (vl-some
47.                       (function (lambda ( b ) (equal a b fz)))
48.                       l1
49.                   )
50.               )
51.           )
52.           l2
53.       )
54.   )
55.  
56.   ;; Get Inside Angle  -  Lee Mac
57.   ;; Returns the smaller angle subtended by three points with vertex at p2
58.  
59.   (defun LM:GetInsideAngle ( p1 p2 p3 )
60.       (   (lambda ( a ) (min a (- (+ pi pi) a)))
61.           (rem (+ pi pi (- (angle p2 p1) (angle p2 p3))) (+ pi pi))
62.       )
63.   )
64.  
65.   ;; 3-Point Circle  -  Lee Mac
66.   ;; Returns the Center and Radius of the Circle defined by
67.   ;; the supplied three points.
68.  
69.   (defun LM:3PCircle ( p1 p2 p3 / cn m1 m2 )
70.       (setq m1 (mid p1 p2)
71.             m2 (mid p2 p3)
72.       )
73.       (list
74.           (setq cn
75.               (inters
76.                   m1 (polar m1 (+ (angle p1 p2) (/ pi 2.)) 1.0)
77.                   m2 (polar m2 (+ (angle p2 p3) (/ pi 2.)) 1.0)
78.                   nil
79.               )
80.           )
81.           (distance cn p1)
82.       )
83.   )
84.  
85.   ;; Midpoint - Lee Mac
86.   ;; Returns the midpoint of two points
87.  
88.   (defun mid ( a b )
89.       (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) a b)
90.   )
91.  
92.   ;; Convex Hull  -  Lee Mac
93.   ;; Implements the Graham Scan Algorithm to determine the
94.   ;; Convex Hull of a list of points.
95.  
96.   (defun LM:ConvexHull ( lst / hul p0 )
97.       (cond
98.           (   (< (length lst) 4)
99.               lst
100.           )
101.           (   t
102.               (setq p0 (car lst))
103.               (foreach p1 (cdr lst)
104.                   (if (or (< (cadr p1) (cadr p0))
105.                           (and (= (cadr p1) (cadr p0)) (< (car p1) (car p0)))
106.                       )
107.                       (setq p0 p1)
108.                   )
109.               )
110.               (setq lst
111.                   (vl-sort lst
112.                       (function
113.                           (lambda ( a b / c d )
114.                               (if (or (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8) (and (or (equal c 0.0 1e-8) (equal c (* 2 pi) 1e-8)) (or (equal d 0.0 1e-8) (equal d (* 2 pi) 1e-8))))
115.                                   (< (distance (list (car p0) (cadr p0)) a) (distance (list (car p0) (cadr p0)) b))
116.                                   (< c d)
117.                               )
118.                           )
119.                       )
120.                   )
121.               )
122.               (setq hul (list (caddr lst) (cadr lst) (car lst)))
123.               (foreach pt (cdddr lst)
124.                   (setq hul (cons pt hul))
125.                   (while (and (caddr hul) (LM:Clockwise-p (caddr hul) (cadr hul) pt))
126.                       (setq hul (cons pt (cddr hul)))
127.                   )
128.               )
129.               hul
130.           )
131.       )
132.   )
133.  
134.   ;; Clockwise-p  -  Lee Mac
135.   ;; Returns T if p1,p2,p3 are clockwise oriented or collinear
136.                    
137.   (defun LM:Clockwise-p ( p1 p2 p3 )
138.       (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
139.               (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
140.           )
141.           1e-8
142.       )
143.   )
144.  
145.   ;; LWPolyline to Point List  -  Lee Mac
146.   ;; Returns a list of points describing the supplied LWPolyline
147.  
148.   (defun LM:LWPoly->List ( ent n / der di1 di2 inc lst par )
149.       (setq par 0)
150.       (repeat (cdr (assoc 90 (entget ent)))
151.           (if (setq der (vlax-curve-getsecondderiv ent par))
152.               (if (equal der '(0.0 0.0 0.0) 1e-8)
153.                   (setq lst (cons (vlax-curve-getpointatparam ent par) lst))
154.                   (if
155.                       (setq di1 (vlax-curve-getdistatparam ent par)
156.                             di2 (vlax-curve-getdistatparam ent (1+ par))
157.                       )
158.                       (progn
159.                           (setq inc (/ (- di2 di1) n))
160.                           (while (< di1 di2)
161.                               (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
162.                                     di1 (+ di1 inc)
163.                               )
164.                           )
165.                           (if (equal (vlax-curve-getpointatdist ent di1) (vlax-curve-getendpoint ent) 1e-8)
166.                               (setq lst (cons (vlax-curve-getendpoint ent) lst))
167.                           )
168.                       )
169.                   )
170.               )
171.           )
172.           (setq par (1+ par))
173.       )
174.       lst
175.   )
176.  
177.   (while (or (not (setq pl (car (entsel "\nPick LWPOLYLINE shape")))) (not (eq (cdr (assoc 0 (entget pl))) "LWPOLYLINE"))))
178.   (initget 7)
179.   (setq n (getint "\nSpecify rotational derivation of full rotation - 360 degree / ? : "))
180.   (setq ri (/ 360.0 n))
181.   (setq ri (* (/ ri 180.0) pi))
182.   (setq c (car (LM:MinEncCircle (LM:LWPoly->List pl 25))))
183.   (repeat n
184.     (vla-rotate (vlax-ename->vla-object pl) (vlax-3d-point c) ri)
185.     (vla-getboundingbox (vlax-ename->vla-object pl) 'minp 'maxp)
186.     (setq minp (vlax-safearray->list minp))
187.     (setq maxp (vlax-safearray->list maxp))
188.     (setq ar (* (abs (- (car maxp) (car minp))) (abs (- (cadr maxp) (cadr minp)))))
189.     (setq arl (cons ar arl))
190. ;    (vla-regen adoc 1)
191.   )
192.   (setq amin (apply 'min arl))
193.   (setq arl (reverse arl))
194.   (setq alst->amin (reverse (member amin (reverse arl))))
195.   (foreach a alst->amin
196.     (vla-rotate (vlax-ename->vla-object pl) (vlax-3d-point c) ri)
197. ;    (vla-regen adoc 1)
198.   )
199.   (vla-getboundingbox (vlax-ename->vla-object pl) 'minp 'maxp)
200.   (setq minp (vlax-safearray->list minp))
201.   (setq maxp (vlax-safearray->list maxp))
202.   (setq bbox (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) (cons 38 (caddr minp)) (cons 10 (list (car minp) (cadr minp))) (cons 10 (list (car maxp) (cadr minp))) (cons 10 (list (car maxp) (cadr maxp))) (cons 10 (list (car minp) (cadr maxp))) (list 210 0.0 0.0 1.0))))
203.   (setq plc (vla-copy (vlax-ename->vla-object pl)))
204.   (setq bbvl (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget bbox))))
205.   (setq bbe (cdr (assoc 38 (entget bbox))))
206.   (setq bbvl (mapcar '(lambda ( x ) (list (car x) (cadr x) bbe)) bbvl))
207.   (setq bbvl (mapcar '(lambda ( x ) (trans x bbox 0)) bbvl))
208.   (setq bbc (car (LM:MinEncCircle bbvl)))
209.   (vla-rotate plc (vlax-3d-point bbc) pi)
210.   (setq vx (mapcar '- (list (car maxp) (cadr maxp)) (list (car minp) (cadr maxp)) ))
211.   (setq vy (mapcar '- (list (car maxp) (cadr maxp)) (list (car maxp) (cadr minp)) ))
212.   (if (< (sqrt (apply '+ (mapcar '* vx vx))) (sqrt (apply '+ (mapcar '* vy vy))))
213.     (setq v vx) (setq v vy)
214.   )
215.   (vla-move plc (vlax-3d-point '(0.0 0.0 0.0)) (vlax-3d-point v))
216.   (entdel bbox)
217.   (initget "Yes No")
218.   (setq ch (getkword "\nIs position of copied and rotated shape OK [Yes/No] <No> : "))
219.   (if (not (eq ch "Yes"))
220.     (vla-move plc (vlax-3d-point v) (vlax-3d-point (mapcar '* v '(-1.0 -1.0 -1.0))))
221.   )
222.   (princ)
223. )
224.  

M.R.

[liuhaixin88]

Look, similar to 1.png you posted... Also applicable only for LWPOLYLINE in WCS and with straight segments (edges)... You have to accept or hit ENTER if position isn't aligned as should...

Thank you very much!  Marko
I'd like to forward your code to “ bbs.mjtd.com” , I will keep the author's name, Do you agree?

[ribarm]

Look, similar to 1.png you posted... Also applicable only for LWPOLYLINE in WCS and with straight segments (edges)... You have to accept or hit ENTER if position isn't aligned as should...

Thank you very much!  Marko
I'd like to forward your code to “ bbs.mjtd.com” , I will keep the author's name, Do you agree?

As you wish, just be sure I won't be fooled and laugh at...

[liuhaixin88]

Look, similar to 1.png you posted... Also applicable only for LWPOLYLINE in WCS and with straight segments (edges)... You have to accept or hit ENTER if position isn't aligned as should...

Thank you very much!  Marko
I'd like to forward your code to “ bbs.mjtd.com” , I will keep the author's name, Do you agree?

As you wish, just be sure I won't be fooled and laugh at...

Thanks, I'm sure not.

[ribarm]

Look, similar to 1.png you posted... Also applicable only for LWPOLYLINE in WCS and with straight segments (edges)... You have to accept or hit ENTER if position isn't aligned as should...

Thank you very much!  Marko
I'd like to forward your code to “ bbs.mjtd.com” , I will keep the author's name, Do you agree?

As you wish, just be sure I won't be fooled and laugh at...

Thanks, I'm sure not.

太好了，我很高興...

[liuhaixin88]

Look, similar to 1.png you posted... Also applicable only for LWPOLYLINE in WCS and with straight segments (edges)... You have to accept or hit ENTER if position isn't aligned as should...

Thank you very much!  Marko
I'd like to forward your code to “ bbs.mjtd.com” , I will keep the author's name, Do you agree?

As you wish, just be sure I won't be fooled and laugh at...

Thanks, I'm sure not.

太好了，我很高興...

Haha, Mr. marko,your Chinese is excellent.