Code Red > AutoLISP (Vanilla / Visual)
Centroid Lisp
ronjonp:
Do any of you have a lisp that will give you the centroid of a closed polyline?
Thanks,
Ron
hendie:
the CENT routine over at www.resourcecad.com can place a point at the centroid if it's a region. a closed polyline doesn't have a centroid property as such
is that what you're after or are you looking for a lisp which will return the centroid as data coordinates ?
CAB:
--- Code: ---;; ******************************************************************************
;; Determine centroid of a polygon
;;
;; Algorithm:
;; 1. Form trapezoids by dropping lines from each segment to a basey axis.
;; 2. Calculate the area and CG of the triangle and rectangle in each trapezoid
;; 3. Sums up weighted moments against given axes in X and Y direction
;; (may use x and y axes if number is small)
;; 4. Derived CG by dividing weighted sum by total area.
;; ******************************************************************************
(defun GE_centroid(vlist / segno n ttl_area basex basey p1 p2 x1 x2 y1 y2
t_x t_y t_area t_xm t_ym r_x r_y r_area r_xm r_ym Mx My)
(setq
vlist (append vlist (list (car vlist)))
segno (1- (length vlist)) ; no of segments
n 0
Ttl_Area 0.0 ; total area
Mx 0.0 ; Sum of moment to basex line
My 0.0 ; Sum of moment to basey line
basex (car (nth 0 vlist)) ; arbitrary axes (will reduce error for large numbers)
basey (cadr (nth 0 vlist))
)
(repeat segno
(setq
p1 (nth n vlist) ; process current segment
p2 (nth (1+ n) vlist)
x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
; For the triangle
t_x (- (* (+ x2 x2 x1) 0.333333) basex) ; cg of trianlge
t_y (- (* (+ y1 y1 y2) 0.333333) basey)
t_area (* (- y2 y1) (- x2 x1) 0.5) ; area of triangle
t_xm (* t_area t_x) ; moment to Basex
t_ym (* t_area t_y) ; moment to basey
; For the rectangle
r_x (- (/ (+ x1 x2) 2) basex) ; CG of rectangle
r_y (- (/ (+ basey y1) 2) basey)
r_area (* (- x2 x1) (- y1 basey)) ; area of rectangle
r_xm (* r_area r_x) ; moment to basex
r_ym (* r_area r_y) ; moment to basey
Ttl_Area (+ Ttl_Area t_area r_area)
Mx (+ Mx t_xm r_xm) ; adds up moments to basex
My (+ My t_ym r_ym) ; adds up moments to basey
n (1+ n)
)
)
(list (+ (/ Mx Ttl_Area) basex) (+ (/ My Ttl_Area) basey))
)
--- End code ---
ronjonp:
thanks guys. :D
Aldo:
I found it on the web, I hope it's of your use
(defun c:pc ( / acdoc acspc acsel pl bl ) (vl-load-com)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace))
)
(if (ssget '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1)))
(progn
(vlax-for obj (setq acsel (vla-get-ActiveSelectionSet acdoc))
(vlax-invoke acspc 'addpoint
(trans
(progn
(setq pl nil bl nil)
(foreach a (reverse (entget (vlax-vla-object->ename obj)))
(cond ((= (car a) 10) (setq pl (cons (cdr a) pl)))
((= (car a) 42) (setq bl (cons (cdr a) bl)))
); _ cond
); _ foreach
;;;(eea-centroid-solid-lw pl bl)
[color="red"] (reverse(cons (vla-get-elevation obj)(reverse (eea-centroid-solid-lw pl bl))));;;VVA MOD 2015-03-29[/color]
)
1 0)
)
)
(vla-delete acsel)
)
)
(princ)
)
(defun eea-centroid-solid-lw (pl bl / A1)
;|
***********************************************************************
by ElpanovEvgeniy
Library function,
Centroids (center of masses) of region, inside [polilinii], which has arched segments.
pl - list of the apexes of [polilinii] (code 10)
bl - list of tangents fourth of angle of the arched segments of [polilinii] (code 42)
Date of the creation 2000 - 2005
Last editorial staff 08.06.2009
URL http://elpanov.com/index.php?id=46
*********************************************************************
Library of function.
Centroid (the of center of of weights) of region, inside of a of polyline, having of arc of segments
pl - list of point
bl - list of bulge
Date of of creation 2000 - 2005 years.
Last of edit 08.06.2009
**********************************************************************
(setq e (car (entsel "\n Select LWPOLYLINE "))
pl nil
bl nil
) ;_ setq
(foreach a (reverse (entget e))
(cond ((= (car a) 10) (setq pl (cons (cdr a) pl)))
((= (car a) 42) (setq bl (cons (cdr a) bl)))
) ;_ cond
) ;_ foreach
(eea-centroid-solid-lw pl bl)
*****************************************************************
(defun c:test (/ e bl pl)
(setq e (car (entsel "\n Select LWPOLYLINE ")))
(foreach a (reverse (entget e))
(cond ((= (car a) 10) (setq pl (cons (cdr a) pl)))
((= (car a) 42) (setq bl (cons (cdr a) bl)))
) ;_ cond
) ;_ foreach
(entmakex (list '(0 . "point")
'(62 . 1)
(cons 10 (eea-centroid-solid-lw pl bl))
(assoc 210 (entget e))
) ;_ list
) ;_ entmakex
) ;_ defun
*******************************************************************
|;
(setq a1 0)
(mapcar
(function /)
(apply
(function mapcar)
(cons
(function +)
(mapcar
(function
(lambda (p1 p2 b / A BB C I S)
(setq i (/ (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1))) 2)
a1 (+ i a1)
i (/ i 3)
) ;_ setq
(if (zerop b)
(mapcar (function (lambda (a b) (* (+ a b) i))) p1 p2)
(progn
(setq c (distance p1 p2)
bb (* b b)
a (/ (* c c (- (* (atan b) (1+ bb) (1+ bb)) (* b (- 1 bb)))) (* 8 bb))
a1 (+ a a1)
s (/ (- (* b c c) (* 3 a (- 1 bb))) (* 12 a b))
) ;_ setq
(mapcar (function (lambda (a b c d) (+ (* (+ a b) i) (* d (+ (/ (+ a b) 2) c)))))
p1
p2
(list (* (- (cadr p2) (cadr p1)) s) (* (- (car p2) (car p1)) -1 s))
(list a a)
) ;_ mapcar
) ;_ progn
) ;_ if
) ;_ lambda
) ;_ function
(cons (last pl) pl)
pl
(cons (last bl) bl)
) ;_ mapcar
) ;_ cons
) ;_ apply
(list a1 a1)
) ;_ mapcar
) ;_ defun
Navigation
[0] Message Index
[#] Next page
Go to full version