Topic: ={ Challenge }=NP-hard problem= moving trajectory

[Q1241274614]

1- object B always in object A;
2- object B does not rotate;
3- objects B moving , along the object A boundary;
4- B-Ymin :The lowest point;
5-  Calculation of the lowest point of the trajectory:Results the trajectory.

[chlh_jd]

Cutting problem is NP-hard problem, is a very large program, it is recommended to use third-party software to complete . Enjoy !

[snownut2]

help!help!help! whats next.

[Q1241274614]

Friend, don't you have any means?

[Q1241274614]

Friend, don't you have any means?

[Kerry]

What have you tried ?

[Q1241274614]

To complete a simple convex polygon!

[Kerry]

Great.
What does the code look like ?

[ribarm]

We don't see on GIF you are actually drawing these convex polygons... Can you show us complete animation?

[ribarm]

It may work with convex polygons, but it may not, you have to test it... And it's only scatter, trajectory polyline you can draw manually according to desired point orientation on smaller polygons after scatter... Better something than nothing - so for start it's not bad...

Code - Auto/Visual Lisp: [Select]

1. (defun c:scatterpolygonpolygon ( / *error* unit rlw ListClockwise-p osm pea msp polmin polmax cmin cmax regmin regmax ptlst k pt intpt intpar par ptmin poll ptt ptt1 ptt2 pttpar parptl ptl ptll pollptlst prevpt prevprevpt nextpt nextnextpt ptper vec ptn prevptpol nextptpol vecp vecn ptnn )
2.  
3.   (vl-load-com)
4.   (setq osm (getvar 'osmode))
5.   (setq pea (getvar 'peditaccept))
6.   (setvar 'osmode 0)
7.   (setvar 'peditaccept 1)
8.  
9.   (defun *error* ( msg )
10.     (if osm (setvar 'osmode osm))
11.     (if pea (setvar 'peditaccept pea))
12.     (if msg (prompt msg))
13.     (princ)
14.   )
15.  
16.   (defun unit ( v )
17.     (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
18.   )
19.  
20.   (defun rlw ( LW / E X1 X2 X3 X4 X5 X6 )
21.     ;; by ElpanovEvgeniy
22.     ;; reverse lwpolyline
23.     (if (= (cdr (assoc 0 (setq e (entget lw)))) "LWPOLYLINE")
24.       (progn (foreach a1 e
25.                (cond ((= (car a1) 10) (setq x2 (cons a1 x2)))
26.                      ((= (car a1) 40) (setq x4 (cons (cons 41 (cdr a1)) x4)))
27.                      ((= (car a1) 41) (setq x3 (cons (cons 40 (cdr a1)) x3)))
28.                      ((= (car a1) 42) (setq x5 (cons (cons 42 (- (cdr a1))) x5)))
29.                      ((= (car a1) 210) (setq x6 (cons a1 x6)))
30.                      (t (setq x1 (cons a1 x1)))
31.                )
32.              )
33.              (entmod (append (reverse x1)
34.                              (append (apply (function append)
35.                                             (apply (function mapcar)
36.                                                    (cons 'list
37.                                                          (list x2
38.                                                                (cdr (reverse (cons (car x3) (reverse x3))))
39.                                                                (cdr (reverse (cons (car x4) (reverse x4))))
40.                                                                (cdr (reverse (cons (car x5) (reverse x5))))
41.                                                          )
42.                                                    )
43.                                             )
44.                                      )
45.                                      x6
46.                              )
47.                      )
48.              )
49.              (entupd lw)
50.       )
51.     )
52.   )
53.  
54.   (defun ListClockwise-p ( lst / z vlst )
55.     (vl-catch-all-apply 'minusp
56.       (list
57.         (if
58.           (not
59.             (equal 0.0
60.               (setq z
61.                 (apply '+
62.                   (mapcar
63.                     (function
64.                       (lambda (u v)
65.                         (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
66.                       )
67.                     )
68.                     (setq vlst
69.                       (mapcar
70.                         (function
71.                           (lambda (a b) (mapcar '- b a))
72.                         )
73.                         (mapcar (function (lambda (x) (car lst))) lst)
74.                         (cdr (reverse (cons (car lst) (reverse lst))))
75.                       )
76.                     )
77.                     (cdr (reverse (cons (car vlst) (reverse vlst))))
78.                   )
79.                 )
80.               ) 1e-6
81.             )
82.           )
83.           z
84.           (progn
85.             (prompt "\n\nChecked vectors are colinear - unable to determine clockwise-p of list")
86.             nil
87.           )
88.         )
89.       )
90.     )
91.   )  
92.  
93.   (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
94.   (setq polmin (car (entsel "\nPick smaller polygon for scattering it inside bigger polygon - LWPOLYLINE")))
95.   (if (not (eq (cdr (assoc 0 (entget polmin))) "LWPOLYLINE"))
96.     (progn
97.       (alert "Picked entity isn't LWPOLYLINE, quitting... Restart routine and pick correct entity...")
98.       (exit)
99.     )
100.   )
101.   (if (not (eq (logand (cdr (assoc 70 (entget polmin))) 1) 1))
102.     (progn
103.       (alert "Picked entity isn't CLOSED polygon, quitting... Restart routine and pick correct entity...")
104.       (exit)
105.     )
106.   )
107.   (if (not (vl-every '(lambda ( x ) (eq (cdr x) 0.0)) (acet-list-m-assoc 42 (entget polmin))))
108.     (progn
109.       (alert "Picked entity has ARCED segment(s), quitting... Restart routine and pick correct entity...")
110.       (exit)
111.     )
112.   )
113.   (setq polmax (car (entsel "\nPick bigger polygon around which vertices routine scatters smaller polygon - LWPOLYLINE")))
114.   (if (not (eq (cdr (assoc 0 (entget polmax))) "LWPOLYLINE"))
115.     (progn
116.       (alert "Picked entity isn't LWPOLYLINE, quitting... Restart routine and pick correct entity...")
117.       (exit)
118.     )
119.   )
120.   (if (not (eq (logand (cdr (assoc 70 (entget polmax))) 1) 1))
121.     (progn
122.       (alert "Picked entity isn't CLOSED polygon, quitting... Restart routine and pick correct entity...")
123.       (exit)
124.     )
125.   )
126.   (if (not (vl-every '(lambda ( x ) (eq (cdr x) 0.0)) (acet-list-m-assoc 42 (entget polmax))))
127.     (progn
128.       (alert "Picked entity has ARCED segment(s), quitting... Restart routine and pick correct entity...")
129.       (exit)
130.     )
131.   )
132.   (setq cmin (vlax-safearray->list (vlax-variant-value (vla-get-centroid (setq regmin (car (vlax-invoke msp 'addregion (list (vlax-ename->vla-object polmin)))))))))
133.   (setq cmax (vlax-safearray->list (vlax-variant-value (vla-get-centroid (setq regmax (car (vlax-invoke msp 'addregion (list (vlax-ename->vla-object polmax)))))))))
134.   (command "_.explode" (vlax-vla-object->ename regmin))
135.   (while (> (getvar 'cmdactive) 0) (command ""))
136.   (command "_.pedit" "_M" "_P" "" "_J" "")
137.   (while (> (getvar 'cmdactive) 0) (command ""))
138.   (entdel polmin)
139.   (setq polmin (entlast))
140.   (command "_.explode" (vlax-vla-object->ename regmax))
141.   (while (> (getvar 'cmdactive) 0) (command ""))
142.   (command "_.pedit" "_M" "_P" "" "_J" "")
143.   (while (> (getvar 'cmdactive) 0) (command ""))
144.   (entdel polmax)
145.   (setq polmax (entlast))
146.   (if (ListClockwise-p (mapcar 'cdr (acet-list-m-assoc 10 (entget polmin)))) (rlw polmin))
147.   (if (ListClockwise-p (mapcar 'cdr (acet-list-m-assoc 10 (entget polmax)))) (rlw polmax))
148.   (command "_.move" polmin "" cmin cmax)
149.   (setq ptlst (mapcar 'cdr (acet-list-m-assoc 10 (entget polmax))))
150.   (setq k -1)
151.   (repeat (length ptlst)
152.     (setq pt (nth (setq k (1+ k)) ptlst))
153.     (command "_.LINE" cmax pt "")
154.     (setq intpt (vlax-invoke (vlax-ename->vla-object (entlast)) 'intersectwith (vlax-ename->vla-object polmin) acextendnone))
155.     (entdel (entlast))
156.     (setq intpar (vlax-curve-getparamatpoint polmin intpt))
157.     (setq par (if (< (- intpar (fix intpar)) 0.5) (fix intpar) (1+ (fix intpar))))
158.     (setq ptmin (vlax-curve-getpointatparam polmin par))
159.     (command "_.COPY" polmin "" ptmin pt)
160.     (setq poll (entlast))
161.     (if (not (equal (list (car pt) (cadr pt) 0.0) (setq ptt (vlax-invoke (vlax-ename->vla-object polmax) 'intersectwith (vlax-ename->vla-object poll) acextendnone)) 1e-3))
162.       (progn
163.         (if (eq (length ptt) 6) (setq ptt (list (list (nth 0 ptt) (nth 1 ptt) (nth 2 ptt)) (list (nth 3 ptt) (nth 4 ptt) (nth 5 ptt)))))
164.         (if (eq (length ptt) 9) (setq ptt (list (list (nth 0 ptt) (nth 1 ptt) (nth 2 ptt)) (list (nth 3 ptt) (nth 4 ptt) (nth 5 ptt)) (list (nth 6 ptt) (nth 7 ptt) (nth 8 ptt)))))
165.         (setq ptt (acet-list-remove-duplicates ptt 1e-3))
166.         (if (eq (length ptt) 2)
167.           (progn
168.             (if (equal (list (car pt) (cadr pt) 0.0) (car ptt) 1e-3) (setq ptt (cadr ptt)) (setq ptt (car ptt)))
169.             (setq pttpar (vlax-curve-getparamatpoint poll ptt))
170.             (setq parptl (if (< (- pttpar (fix pttpar)) 0.5) (fix pttpar) (1+ (fix pttpar))))
171.             (setq ptl (vlax-curve-getpointatparam poll parptl))
172.             (setq ptl (list (car ptl) (cadr ptl)))
173.             (setq pollptlst (mapcar 'cdr (acet-list-m-assoc 10 (entget poll))))
174.             (setq prevpt (if (equal pt (car pollptlst) 1e-3) (last pollptlst) (cadr (member pt (reverse pollptlst)))))
175.             (setq nextpt (if (equal pt (last pollptlst) 1e-3) (car pollptlst) (cadr (member pt pollptlst))))
176.             (setq prevprevpt (if (equal prevpt (car pollptlst) 1e-3) (last pollptlst) (cadr (member prevpt (reverse pollptlst)))))
177.             (setq nextnextpt (if (equal nextpt (last pollptlst) 1e-3) (car pollptlst) (cadr (member nextpt pollptlst))))
178.             (if (or (equal prevpt ptl 1e-3) (equal prevprevpt ptl 1e-3)) (setq ptl prevpt))
179.             (if (or (equal nextpt ptl 1e-3) (equal nextnextpt ptl 1e-3)) (setq ptl nextpt))
180.             (setq ptper (vlax-curve-getclosestpointto polmax ptl))
181.             (setq ptper (list (car ptper) (cadr ptper)))
182.             (setq vec (mapcar '- pt ptper))
183.             (setq ptn (mapcar '+ pt (mapcar '- ptper ptl)))
184.             (command "_.move" poll "" ptl ptper)
185.             (setq prevptpol (if (equal pt (car ptlst) 1e-3) (last ptlst) (cadr (member pt (reverse ptlst)))))
186.             (setq nextptpol (if (equal pt (last ptlst) 1e-3) (car ptlst) (cadr (member pt ptlst))))
187.             (setq vecp (mapcar '- pt prevptpol))
188.             (setq vecn (mapcar '- pt nextptpol))
189.             (if (equal (unit vec) (unit vecp) 1e-3)
190.               (progn
191.                 (setq ptnn (inters ptn (mapcar '+ ptn vec) pt nextptpol nil))
192.                 (command "_.move" poll "" ptn ptnn)
193.               )
194.               (progn
195.                 (setq ptnn (inters ptn (mapcar '+ ptn vec) pt prevptpol nil))
196.                 (command "_.move" poll "" ptn ptnn)
197.               )
198.             )
199.           )
200.           (progn
201.             (foreach p ptlst
202.               (if (vl-member-if '(lambda ( x ) (equal x (list (car p) (cadr p) 0.0) 1e-3)) ptt)
203.                 (setq ptt (vl-remove-if '(lambda ( x ) (equal x (list (car p) (cadr p) 0.0) 1e-3)) ptt))
204.               )
205.             )
206.             (setq ptt1 (car ptt))
207.             (setq ptt2 (cadr ptt))
208.  
209.             (setq pttpar (vlax-curve-getparamatpoint poll ptt1))
210.             (setq parptl (if (< (- pttpar (fix pttpar)) 0.5) (fix pttpar) (1+ (fix pttpar))))
211.             (setq ptl (vlax-curve-getpointatparam poll parptl))
212.             (setq ptl (list (car ptl) (cadr ptl)))
213.             (setq pollptlst (mapcar 'cdr (acet-list-m-assoc 10 (entget poll))))
214.             (setq prevpt (if (equal pt (car pollptlst) 1e-3) (last pollptlst) (cadr (member pt (reverse pollptlst)))))
215.             (setq nextpt (if (equal pt (last pollptlst) 1e-3) (car pollptlst) (cadr (member pt pollptlst))))
216.             (setq prevprevpt (if (equal prevpt (car pollptlst) 1e-3) (last pollptlst) (cadr (member prevpt (reverse pollptlst)))))
217.             (setq nextnextpt (if (equal nextpt (last pollptlst) 1e-3) (car pollptlst) (cadr (member nextpt pollptlst))))
218.             (if (or (equal prevpt ptl 1e-3) (equal prevprevpt ptl 1e-3)) (setq ptl prevpt))
219.             (if (or (equal nextpt ptl 1e-3) (equal nextnextpt ptl 1e-3)) (setq ptl nextpt))
220.             (setq ptper (vlax-curve-getclosestpointto polmax ptl))
221.             (setq ptper (list (car ptper) (cadr ptper)))
222.             (setq vec (mapcar '- pt ptper))
223.  
224.             (setq pttpar (vlax-curve-getparamatpoint poll ptt2))
225.             (setq parptl (if (< (- pttpar (fix pttpar)) 0.5) (fix pttpar) (1+ (fix pttpar))))
226.             (setq ptll (vlax-curve-getpointatparam poll parptl))
227.             (setq ptll (list (car ptll) (cadr ptll)))
228.             (setq pollptlst (mapcar 'cdr (acet-list-m-assoc 10 (entget poll))))
229.             (setq prevpt (if (equal pt (car pollptlst) 1e-3) (last pollptlst) (cadr (member pt (reverse pollptlst)))))
230.             (setq nextpt (if (equal pt (last pollptlst) 1e-3) (car pollptlst) (cadr (member pt pollptlst))))
231.             (setq prevprevpt (if (equal prevpt (car pollptlst) 1e-3) (last pollptlst) (cadr (member prevpt (reverse pollptlst)))))
232.             (setq nextnextpt (if (equal nextpt (last pollptlst) 1e-3) (car pollptlst) (cadr (member nextpt pollptlst))))
233.             (if (or (equal prevpt ptll 1e-3) (equal prevprevpt ptll 1e-3)) (setq ptll prevpt))
234.             (if (or (equal nextpt ptll 1e-3) (equal nextnextpt ptll 1e-3)) (setq ptll nextpt))
235.  
236.             (setq ptn (mapcar '+ ptll (mapcar '- ptper ptl)))
237.             (command "_.move" poll "" ptl ptper)
238.             (setq prevptpol (if (equal pt (car ptlst) 1e-3) (last ptlst) (cadr (member pt (reverse ptlst)))))
239.             (setq nextptpol (if (equal pt (last ptlst) 1e-3) (car ptlst) (cadr (member pt ptlst))))
240.             (setq vecp (mapcar '- pt prevptpol))
241.             (setq vecn (mapcar '- pt nextptpol))
242.             (if (equal (unit vec) (unit vecp) 1e-3)
243.               (progn
244.                 (setq ptnn (inters ptn (mapcar '+ ptn vec) pt nextptpol nil))
245.                 (command "_.move" poll "" ptn ptnn)
246.               )
247.               (progn
248.                 (setq ptnn (inters ptn (mapcar '+ ptn vec) pt prevptpol nil))
249.                 (command "_.move" poll "" ptn ptnn)
250.               )
251.             )
252.           )
253.         )
254.       )
255.     )
256.   )
257.  
258.   (*error* nil)
259.   (princ)
260. )
261.  
262. (defun c:spp nil (c:scatterpolygonpolygon))
263. (prompt "\nInvoke with 'SPP' command")
264. (princ)
265.  

[ribarm]

Fixed some minor bugs, code updated... It should scatter all small polygons along vertices of big polygon, but result can be also undesired - it depends from case to case... Make sure you draw convex polygons... Waiting for your reply Q1241274614...

Regards, M.R.

[Q1241274614]

The best results are arbitrary structure, concave edge shape is also possible.


Do not know how to copy your files, because there are a lot of digital.

thank!

[ribarm]

The best results are arbitrary structure, concave edge shape is also possible.

I designed this to work with convex polygons... Maybe some case with concave can actually succeed, but I didn't try...

Do not know how to copy your files, because there are a lot of digital.

You can use [Select] button beside code heading to quickly select code, then use ctrl+c (copy), open notepad or some other text editor and use ctrl+v (paste), and then save file as SPP.lsp... If you don't succeed I'll upload my version of *.lsp, so you can download it...

thank!

You're welcome...

[Q1241274614]

thank ribarm !
At night I try.

[ribarm]

A little mistake, now fixed, try download now... Thanks for your patience, M.R.