### Author Topic: Adjust the area of a polygon  (Read 8773 times)

0 Members and 1 Guest are viewing this topic.

#### MP ##### Re: Adjust the area of a polygon
« Reply #15 on: March 09, 2014, 03:46:12 PM »
lol
Engineering Technologist  CAD Automation Practitioner
Automation ▸ Design ▸ Drafting ▸ Document Control ▸ Client

#### snownut2

• Swamp Rat
• Posts: 971 ##### Re: Adjust the area of a polygon
« Reply #16 on: March 09, 2014, 04:25:25 PM »
lol

you're a sport... • Mosquito
• Posts: 9 ##### Re: Adjust the area of a polygon
« Reply #17 on: March 10, 2014, 06:00:17 AM »
Hello, this is my first post and I need your help. I am looking for a program in which the user selects a polyline, writes the desired area, then selects some vertices on that polyline and the program will stretch the selected vertices until the desired area is achieved. Can this be done?

#### mailmaverick

• Bull Frog
• Posts: 470 ##### Re: Adjust the area of a polygon
« Reply #18 on: March 11, 2014, 03:06:45 AM »

I dont think such a LISP is possible because there would be unlimited combinations of each vertex to be stretched. ##### Re: Adjust the area of a polygon
« Reply #19 on: March 11, 2014, 05:31:26 AM »
I would suggest rather simple code as Roy proposed - scaling instead of stretching...

Code: [Select]
`(defun c:scf ( / ent ea len nlen cir ncir are nare vol nvol ch sf bp )  (vl-load-com)  (setq ent (car (entsel "\nPick entity for scaling")))  (if (vlax-property-available-p (setq ea (vlax-ename->vla-object ent)) 'Length)    (setq len (vla-get-length ea))    (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getendparam (list ea)))) (setq len (- (vlax-curve-getdistatparam ea (vlax-curve-getendparam ea)) (vlax-curve-getdistatparam ea (vlax-curve-getstartparam ea)))))  )  (if (vlax-property-available-p ea 'Circumference)    (setq cir (vla-get-circumference ea))  )  (if (vlax-property-available-p ea 'Area)    (setq are (vla-get-area ea))  )  (if (vlax-property-available-p ea 'Volume)    (setq vol (vla-get-volume ea))  )  (prompt "\nChoose current parameter to adjust while scaling : 1.Length = ") (princ len) (prompt "; 2.Circumference = ") (princ cir) (prompt "; 3.Area = ") (princ are) (prompt "; 4.Volume = ") (princ vol) (prompt " : ")  (initget "1 2 3 4")  (setq ch (getkword))  (cond    ( (eq ch "1")      (initget 7)      (setq nlen (getreal "\nSpecify desired Length : "))      (setq sf (/ nlen len))    )    ( (eq ch "2")      (initget 7)      (setq ncir (getreal "\nSpecify desired Circumference : "))      (setq sf (/ ncir cir))    )    ( (eq ch "3")      (initget 7)      (setq nare (getreal "\nSpecify desired Area : "))      (setq sf (expt (/ nare are) (/ 1.0 2.0)))    )    ( (eq ch "4")      (initget 7)      (setq nvol (getreal "\nSpecify desired Volume : "))      (setq sf (expt (/ nvol vol) (/ 1.0 3.0)))    )  )  (setq bp (getpoint "\nPick base point for scale by factor for desired parameter : "))  (vla-scaleentity ea (vlax-3d-point bp) sf)  (princ))`
« Last Edit: March 11, 2014, 06:37:13 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture) • Mosquito
• Posts: 9 ##### Re: Adjust the area of a polygon
« Reply #20 on: March 11, 2014, 12:04:24 PM »
Thank you ribarm. I already made a program which scales a polyline using the centroid, but this is good too.I tried to make myself a program, but it gives me an error and I don't know why. It will help me very much if you can help me to get rid of that error. Here is the code:
Code - Auto/Visual Lisp: [Select]
1. (defun c:ms ()
2. (setvar "CMDECHO" 0)
3. (command "undo" "begin")
4. (setq os_old (getvar "OSMODE"))
5. (setvar "OSMODE" 1)
6. (setq lista '())
7. (setq obj (car (entsel "\nSelecteaza conturul: ")))
8. (while (not obj)
9. (setq obj (car (entsel "\nSelecteaza conturul: ")))
10. )
11. (if (wcmatch (cdr (assoc 0 (entget obj))) "*POLYLINE")
12. ;;facem lista cu coordonatele
13. (foreach x (setq e (entget obj))
14.         (if (= 10 (car x)) (setq l (cons (cdr x) l)))
15.     )
16. (vla-put-closed (vlax-ename->vla-object obj) :vlax-true)
17. (setq arieinitiala (vla-get-Area (vlax-ename->vla-object obj)))
18. (initget (+ 1 2 4))
19. (setq ariedor (getreal (strcat "\nScrieti suprafata la care doriti sa ajungeti <" (rtos arieinitiala 2 2) "mp> ")))
20. ;;daca aria dorita este egala cu aria initiala
21. (if (= (rtos ariedor 2 0) (rtos arieinitiala 2 0))
22. (alert "\nAti ales aceeasi arie cu cea a conturului!")
23. (setq pt (getpoint "\nAlegeti punctele din care se modifica suprafata: "))
24. (setq xpt (car pt))
26. (if (not (member (list xpt ypt) l))
27. (alert "\nPunctul trebuie sa fie un vertex al conturului!")
28. (setq lista (append (list (list xpt ypt)) lista))
29. )
30. )
31. (setq lista (reverse lista))
32. (setq lista (LI_MakeUnique lista))
33. (mapcar '(lambda (x) (= 0.01 x)) '(offset1 offset2 offset3 offset4 offset5 offset6 offset7 offset8 offset9 offset10 offset11 offset12 offset13 offset14 offset15))
34. (setq arieobj arieinitiala)
35. ;;Cazul 1
36. ;;Aria dorita este mai mica decat aria initiala
37. ((< ariedor arieinitiala)
38. (while (< ariedor arieinitiala)
39. (foreach item lista
40. (setq xprev (car (vlax-curve-getPointAtParam (vlax-ename->vla-object obj) (1- (vlax-curve-getParamAtPoint (vlax-ename->vla-object obj) item)))))
41. (setq yprev (cadr (vlax-curve-getPointAtParam (vlax-ename->vla-object obj) (1- (vlax-curve-getParamAtPoint (vlax-ename->vla-object obj) item)))))
42. (setq xnext (car (vlax-curve-getPointAtParam (vlax-ename->vla-object obj) (1+ (vlax-curve-getParamAtPoint (vlax-ename->vla-object obj) item)))))
43. (setq ynext (cadr (vlax-curve-getPointAtParam (vlax-ename->vla-object obj) (1+ (vlax-curve-getParamAtPoint (vlax-ename->vla-object obj) item)))))
44. ((and (or (<= xprev (car item))  (>= xprev (car item))) (>= xnext (car item)) (>= ynext (cadr item)) (<= yprev (cadr item)))
45. (command "stretch" "c" item item "" item (list (+ (car item) offset1) (cadr item)))
46. (setq offset1 (+ 0.01 offset1))
47. )
48. ((and (or (<= xprev (car item)) (>= xprev (car item))) (>= xnext (car item)) (>= ynext (cadr item))  (>= yprev (cadr item)))
49. (command "stretch" "c" item item "" item (list (car item) (+ (cadr item) offset2)))
50. (setq offset2 (+ 0.01 offset2))
51. )
52. ((and (>= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (>= yprev (cadr item)))
53. (command "stretch" "c" item item "" item (list (- (car item) offset3) (cadr item)))
54. (setq offset3 (+ offset 0.01))
55. )
56. ((and (>= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (<= yprev (cadr item)))
57. (command "stretch" "c" item item "" item (list (car item) (- (cadr item) offset4)))
58. (setq offset4 (+ offset4 0.01))
59. )
60. ((and (>= xnext (car item)) (<= ynext (cadr item)) (>= xprev (car item)) (<= yprev (cadr item)))
61. (command "stretch" "c" item item "" item (list (+ (car item) offset5) (- (cadr item) offset5)))
62. (setq offset5 (+ offset5 0.01))
63. )
64. ((and (>= xnext (car item)) (<= ynext (cadr item)) (>= xprev (car item)) (>= yprev (cadr item)))
65. (command "stretch" "c" item item "" item (list (+ (car item) offset6) (cadr item)))
66. (setq offset6 (+ offset7 0.01))
67. )
68. ((and (<= xnext (car item)) (>= ynext (cadr item)) (<= xprev (car item)) (<= yprev (cadr item)))
69. (command "stretch" "c" item item "" item (list (- (car item) offset8) (cadr item)))
70. (setq offset7 (+ offset7 0.01))
71. )
72. ((and (<= xnext (car item)) (>= ynext (cadr item)) (<= xprev (car item)) (>= yprev (cadr item)))
73. (command "stretch" "c" item item "" item (list (- (car item) offset8) (+ (cadr item) offset8)))
74. (setq offset8 (+ offset8 0.01))
75. )
76. ((and (<= xnext (car item)) (>= ynext (cadr item)) (>= xprev (car item)) (<= yprev (cadr item)))
77. (command "stretch" "c" item item "" item (list (+ (car item) offset9) (+ (cadr item) offset9)))
78. (setq offset9 (+ offset9 0.01))
79. )
80. ((and (<= xnext (car item)) (>= ynext (cadr item)) (>= xprev (car item)) (>= yprev (cadr item)))
81. (command "stretch" "c" item item "" item (list (car item) (+ (cadr item) offset10)))
82. (setq offset10 (+ offset10 0.01))
83. )
84. ((and (<= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (<= yprev (cadr item)))
85. (command "stretch" "c" item item "" item (list (- (car item) offset11) (- (cadr item) offset11)))
86. (setq offset11 (+ offset11 0.01))
87. )
88. ((and (<= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (>= yprev (cadr item)))
89. (command "stretch" "c" item item "" item (list (+ (car item) offset12) (cadr item)))
90. (setq offset12 (+ offset12 0.01))
91. )
92. ((and (<= xnext (car item)) (<= ynext (cadr item)) (>= xprev (car item)) (>= yprev (cadr item)))
93. (command "stretch" "c" item item "" item (list (+ (car item) offset13) (- (cadr item) offset13)))
94. (setq offset13 (+ offset13 0.01))
95. )
96. ((and (<= xnext (car item)) (<= ynext (cadr item)) (>= xprev (car item)) (<= yprev (cadr item)))
97. (command "stretch" "c" item item "" item (list (car item) (- (cadr item) offset14)))
98. (setq offset14 (+ offset14 0.01))
99. )
100. ((and (<= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (<= yprev (cadr item)))
101. (command "stretch" "c" item item "" item (list (- (car item) offset15) (- (cadr item) offset15)))
102. (setq offset15 (+ offset15 0.01))
103. )
104. (T nil)
105. )
106. )
107. )
108. )
109. ((> ariedor arieinitiala)
110. (while (> ariedor arieinitiala)
111. (foreach item lista
112. ;;verificam daca e si pct de start selectat
113. (setq xnext (car (vlax-curve-getPointAtParam (vlax-ename->vla-object obj) (1+ (vlax-curve-getParamAtPoint (vlax-ename->vla-object obj) item)))))
114. (setq ynext (cadr (vlax-curve-getPointAtParam (vlax-ename->vla-object obj) (1+ (vlax-curve-getParamAtPoint (vlax-ename->vla-object obj) item)))))
115. (setq xprev (car (vlax-curve-getPointAtParam (vlax-ename->vla-object obj) (1- (vlax-curve-getParamAtPoint (vlax-ename->vla-object obj) item)))))
116. (setq yprev (cadr (vlax-curve-getPointAtParam (vlax-ename->vla-object obj) (1- (vlax-curve-getParamAtPoint (vlax-ename->vla-object obj) item)))))
117. ((and (>= xnext (car item)) (>= ynext (cadr item)) (or (<= xprev (car item))  (>= xprev (car item))) (<= yprev (cadr item)))
118. (command "stretch" "c" item item "" item (list (- (car item) offset1) (cadr item)))
119. (setq offset1 (+ 0.01 offset1))
120. )
121. ((and (>= xnext (car item)) (>= ynext (cadr item)) (or (<= xprev (car item)) (>= xprev (car item))) (>= yprev (cadr item)))
122. (command "stretch" "c" item item "" item (list (car item) (- (cadr item) offset2)))
123. (setq offset2 (+ 0.01 offset2))
124. )
125. ((and (>= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (>= yprev (cadr item)))
126. (command "stretch" "c" item item "" item (list (+ (car item) offset3) (cadr item)))
127. (setq offset3 (+ offset 0.01))
128. )
129. ((and (>= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (<= yprev (cadr item)))
130. (command "stretch" "c" item item "" item (list (car item) (+ (cadr item) offset4)))
131. (setq offset4 (+ offset4 0.01))
132. )
133. ((and (>= xnext (car item)) (<= ynext (cadr item)) (>= xprev (car item)) (<= yprev (cadr item)))
134. (command "stretch" "c" item item "" item (list (- (car item) offset5) (+ (cadr item) offset5)))
135. (setq offset5 (+ offset5 0.01))
136. )
137. ((and (>= xnext (car item)) (<= ynext (cadr item)) (>= xprev (car item)) (>= yprev (cadr item)))
138. (command "stretch" "c" item item "" item (list (- (car item) offset6) (cadr item)))
139. (setq offset6 (+ offset7 0.01))
140. )
141. ((and (<= xnext (car item)) (>= ynext (cadr item)) (<= xprev (car item)) (<= yprev (cadr item)))
142. (command "stretch" "c" item item "" item (list (+ (car item) offset8) (cadr item)))
143. (setq offset7 (+ offset7 0.01))
144. )
145. ((and (<= xnext (car item)) (>= ynext (cadr item)) (<= xprev (car item)) (>= yprev (cadr item)))
146. (command "stretch" "c" item item "" item (list (+ (car item) offset8) (+ (cadr item) offset8)))
147. (setq offset8 (+ offset8 0.01))
148. )
149. ((and (<= xnext (car item)) (>= ynext (cadr item)) (>= xprev (car item)) (<= yprev (cadr item)))
150. (command "stretch" "c" item item "" item (list (- (car item) 0.01) (- (cadr item) 0.01)))
152. (setq offset9 (+ offset9 0.01))
153. )
154. ((and (<= xnext (car item)) (>= ynext (cadr item)) (>= xprev (car item)) (>= yprev (cadr item)))
155. (command "stretch" "c" item item "" item (list (car item) (- (cadr item) offset10)))
156. (setq offset10 (+ offset10 0.01))
157. )
158. ((and (<= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (<= yprev (cadr item)))
159. (command "stretch" "c" item item "" item (list (+ (car item) offset11) (+ (cadr item) offset11)))
160. (setq offset11 (+ offset11 0.01))
161. )
162. ((and (<= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (>= yprev (cadr item)))
163. (command "stretch" "c" item item "" item (list (- (car item) offset12) (cadr item)))
164. (setq offset12 (+ offset12 0.01))
165. )
166. ((and (<= xnext (car item)) (<= ynext (cadr item)) (>= xprev (car item)) (>= yprev (cadr item)))
167. (command "stretch" "c" item item "" item (list (- (car item) offset13) (+ (cadr item) offset13)))
168. (setq offset13 (+ offset13 0.01))
169. )
170. ((and (<= xnext (car item)) (<= ynext (cadr item)) (>= xprev (car item)) (<= yprev (cadr item)))
171. (command "stretch" "c" item item "" item (list (car item) (+ (cadr item) offset14)))
172. (setq offset14 (+ offset14 0.01))
173. )
174. ((and (<= xnext (car item)) (<= ynext (cadr item)) (<= xprev (car item)) (<= yprev (cadr item)))
175. (command "stretch" "c" item item "" item (list (+ (car item) offset15) (+ (cadr item) offset15)))
176. (setq offset15 (+ offset15 0.01))
177. )
178. (T nil)
179. )
180. )
181. )
182. )
183. (T nil)
184. )
185. )
186. )
187. )
188. )
189. (command "undo" "end")
190. (setvar "OSMODE" os_old)
191. )
192.
193. (defun LI_MakeUnique( Lst / Lst1 tmp )
194.
195. (setq Lst1 '())
196. (foreach tmp Lst
197.         (if (not (member tmp Lst1))
198.                 (setq Lst1 (cons tmp Lst1))
199.         )
200. )
201. (reverse Lst1)
202. ) ##### Re: Adjust the area of a polygon
« Reply #21 on: March 11, 2014, 12:21:36 PM »
Polyline can have unlimited number of vertices... How do you determine which vertices do you want to stretch to achieve desired area? Beside that you defined 15 point stretches... I would define (while) loop to pick desired vertices and then define vector by picking 2 points that will determine direction of stretching... But then again routine will have to increment stretching by some small factor until relatively correct area is reached, but it'll take time and area would be not exactly correct...
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: Adjust the area of a polygon
« Reply #22 on: March 11, 2014, 12:46:46 PM »
My first look at the problem and looks like two adjacent vertices need to move & four angles would change to adjust the area. (Keeping all side the same length)
My guess is that you can move the two vertices in one of two general directions and likely get the desired area.

So you will need to pick two vertices to move & the direction to move them OR use the shortest distance to determine the direction.
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970 ##### Re: Adjust the area of a polygon
« Reply #23 on: March 11, 2014, 01:06:13 PM »
Looking at another polygon it looks doable.
Pick points 1 and 2 & the segment 1-2 can be moved maintaining adjacent segment lengths.
haven't looked for an algorithm to accomplish this.
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970

• Mosquito
• Posts: 9 ##### Re: Adjust the area of a polygon
« Reply #24 on: March 11, 2014, 01:14:23 PM »
ribarm, the routine I posted does exactly what you said, but it's not working and until now, I don't know from where that error is coming.
Cab, I don't care how the vertices are stretched because for me both solutions are fine if the desired area is achieved.
My code should do the trick, but I get an bad argument type numberp nil error. ##### Re: Adjust the area of a polygon
« Reply #25 on: March 11, 2014, 01:15:06 PM »
Either points 1 or 2 can independently be rotated around centers of circles, so how do you know which one is right and if both are to be rotated how do you know direction of rotation?
Marko Ribar, d.i.a. (graduated engineer of architecture)  ##### Re: Adjust the area of a polygon
« Reply #26 on: March 11, 2014, 01:17:12 PM »
vladgothe, where in the code do you specify dirction vector for stretching? - it isn't what I described...
Marko Ribar, d.i.a. (graduated engineer of architecture) • Mosquito
• Posts: 9 ##### Re: Adjust the area of a polygon
« Reply #27 on: March 11, 2014, 01:22:49 PM »
In the stretch command. I'm sorry, I forgot to translate in english language. In my code, the user selects the polyline, inputs the desired area, then selects the vertices to be stretched. The rules for stretching every vertex are defined in the cond statement.
I am a beginner in lisp, so I may be wrong and that's why I need your help. If you can, I would like you to run my code and see the cause of that error.
Cab, is not necessary to preserve adjacent segments lengths, they can be modified.
« Last Edit: March 11, 2014, 01:34:16 PM by vladgothe »

#### pedroantonio

• Guest ##### Re: Adjust the area of a polygon
« Reply #28 on: March 11, 2014, 02:57:56 PM »
nice job ribarm

1)select polyline
2)Specify desired Length  and Specify desired area
3)Pick two points to avoid the rotation
4)calculate the polygon ##### Re: Adjust the area of a polygon
« Reply #29 on: March 11, 2014, 04:12:44 PM »
`(defun c:ms ( / adoc ar d k nar osm p1 p2 pl pla pt ptlst ptt vf )  (vl-load-com)  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))  (setq osm (getvar 'osmode))  (prompt "\nPick closed POLYLINE")  (setq pl (ssname (ssget "_+.:E:S:L" '((0 . "*POLYLINE") (-4 . "&=") (70 . 1))) 0))  (setq ar (vla-get-area (setq pla (vlax-ename->vla-object pl))))  (prompt "\nSpecify new desired area value - old was : ") (princ (rtos ar 2 2)) (prompt " ; - : ")  (initget 7)  (setq nar (getreal))  (setvar 'osmode 1)  (setq pt (getpoint "\nPick start vertex on POLYLINE for stretching : "))  (while pt    (setq ptlst (cons pt ptlst))    (setq pt (getpoint "\nPick next vertex on POLYLINE for stretching - ENTER to finish : "))  )  (setq p1 (getpoint "\nPick first-start point of stretch vector direction : "))  (setq p2 (getpoint "\nPick second-end point of stretch vector direction : "))  (setvar 'osmode 0)  (vla-startundomark adoc)  (foreach pt ptlst    (command "_.stretch" "_C" pt pt "" pt (mapcar '+ pt (mapcar '- p2 p1)))  )  (if (and (> nar ar) (> (vla-get-area pla) ar)) (setq vf t))  (if (and (> nar ar) (< (vla-get-area pla) ar)) (setq vf nil))  (if (and (< nar ar) (< (vla-get-area pla) ar)) (setq vf t))  (if (and (< nar ar) (> (vla-get-area pla) ar)) (setq vf nil))  (if (and (> nar ar) vf)    (progn      (setq k 0.0)      (setq ptt (mapcar '/ (mapcar '- p2 p1) (list (setq d (* (distance p1 p2) 100.0)) d d)))      (while (> nar (vla-get-area pla))        (command "_.undo" "_B")        (foreach pt ptlst          (command "_.stretch" "_C" pt pt "" pt (mapcar '+ pt (mapcar '* ptt (list (setq k (1+ k)) k k))))        )        (vla-update pla)      )    )  )  (if (and (> nar ar) (not vf))    (progn      (setq k 0.0)      (setq ptt (mapcar '/ (mapcar '- p1 p2) (list (setq d (* (distance p1 p2) 100.0)) d d)))      (while (> nar (vla-get-area pla))        (command "_.undo" "_B")        (foreach pt ptlst          (command "_.stretch" "_C" pt pt "" pt (mapcar '+ pt (mapcar '* ptt (list (setq k (1+ k)) k k))))        )        (vla-update pla)      )    )  )  (if (and (< nar ar) vf)    (progn      (setq k 0.0)      (setq ptt (mapcar '/ (mapcar '- p2 p1) (list (setq d (* (distance p1 p2) 100.0)) d d)))      (while (< nar (vla-get-area pla))        (command "_.undo" "_B")        (foreach pt ptlst          (command "_.stretch" "_C" pt pt "" pt (mapcar '+ pt (mapcar '* ptt (list (setq k (1+ k)) k k))))        )        (vla-update pla)      )    )  )  (if (and (< nar ar) (not vf))    (progn      (setq k 0.0)      (setq ptt (mapcar '/ (mapcar '- p1 p2) (list (setq d (* (distance p1 p2) 100.0)) d d)))      (while (< nar (vla-get-area pla))        (command "_.undo" "_B")        (foreach pt ptlst          (command "_.stretch" "_C" pt pt "" pt (mapcar '+ pt (mapcar '* ptt (list (setq k (1+ k)) k k))))        )        (vla-update pla)      )    )  )  (vla-endundomark adoc)  (setvar 'osmode osm)  (princ))` 