TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: CAB on November 12, 2006, 12:53:19 PM
-
Challenge:
Create a subroutine to Draw / Entmake a regular polygon.
Given:
- Center point
- No. of Sides >2
- Size - Radius Value
- Inscribe or Circumscribe Flag
-
Here's my contribution :
;; Center point -> cen
;; No. of Sides >2 -> nb
;; Size - Radius Value -> rad
;; Inscribe or Circumscribe Flag -> flag
(defun draw_polygon (cen nb rad flag / zdir elv n lst)
(setq zdir (trans '(0 0 1) 1 0 T)
elv (- (caddr cen) (caddr (trans '(0 0 0) 0 1)))
cen (list (car cen) (cadr cen) 0.0)
n nb
)
(if (= flag "Circumscribe")
(setq rad (/ rad (cos (/ pi nb))))
)
(repeat nb
(setq lst (cons (polar cen (* (/ (* 2 pi) nb) (setq n (1- n))) rad) lst))
)
(entmake
(append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 nb)
'(70 . 1)
(cons 38 elv)
(cons 210 zdir)
)
(mapcar '(lambda (pt) (cons 10 (trans pt 1 zdir))) lst)
)
)
)
EDIT: add a test function.
(defun c:test (/ cen nb rad flag)
(setq cen (getpoint "\nCenter: ")
nb (getint "\nNumber of sides: ")
rad (getdist cen "\Radius: ")
)
(initget 1 "Inscribe Circumscribe")
(setq
flag (getkword "\nInscribe or Circumscribe ? [Inscribe/Circumscribe]: ")
)
(draw_polygon cen nb rad flag)
(princ)
)
-
As always I/m late again :)
(defun _entmake_polygon_eX (pt no rad flag / a da cnt pt pts rad x y)
(setq da (/ (* 2 pi) no)
rad (if flag ;Inscribe
rad
(* rad (cos (/ pi no))));Circumscribe
cnt 0
a 0
)
(while (< cnt no)
(setq a (* da cnt))
(setq x (* rad (cos a))
y (* rad (sin a))
)
(setq pts (cons (list x y) pts))
(setq cnt (1+ cnt))
)
(setq pts (mapcar (function (lambda (x)
(mapcar '+ x pt)
)
)
(reverse pts)
)
)
(entmake
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 no)
(cons 70 1)
(cons 43 0.0)
)
(mapcar (function (lambda (x)
(cons 10 x)
)
)
pts
)
)
)
)
;TesT :
(_entmake_polygon_eX '(0 0) 9 42.545 nil)
(_entmake_polygon_eX '(0 0) 9 42.545 t)
~'J'~
-
Great job Guy's.
Gile your's works as expected.
Fatty your Inscribe is as expected but the circumscribe is not.
With circumscribe the apothem and radius entered should be the same.
-
Great job Guy's.
Gile your's workes as expected.
Fatty your Inscribe is as expected but the circumscribe is not.
With circumscribe the apothem and radius entered should be the same.
Thank you, Alan,
here is edited version, I don't know why I have used multiple
instead of divide, sorry :|
(defun _entmake_polygon_eX (pt no rad flag / a da cnt pt pts rad x y)
(setq da (/ (* 2 pi) no)
rad (if flag
(/ rad (cos (/ pi no))) ;Circumscribe
rad ;Inscribe
)
cnt 0
a 0
)
(while (< cnt no)
(setq a (* da cnt))
(setq x (* rad (cos a))
y (* rad (sin a))
)
(setq pts (cons (list x y) pts))
(setq cnt (1+ cnt))
)
(setq pts (mapcar (function (lambda (x)
(mapcar '+ x pt)
)
)
(reverse pts)
)
)
(entmake
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 no)
(cons 70 1)
(cons 43 0.0)
)
(mapcar (function (lambda (x)
(cons 10 x)
)
)
pts
)
)
)
)
;TesT :
(_entmake_polygon_eX '(0 0) 8 50.0 nil);Inscribe
(_entmake_polygon_eX '(0 0) 8 50.0 t);Circumscribe
here is another one, where I have to used the segment length as a size
(defun _entmake_polygonSeg (pt no segm / a da cnt pt pts rad x y)
(setq da (/ (* 2 pi) no)
rad (/ segm 2 (sin (/ pi no)))
cnt 0
a 0
)
(while (< cnt no)
(setq a (* da cnt))
(setq x (* rad (cos a))
y (* rad (sin a))
)
(setq pts (cons (list x y) pts))
(setq cnt (1+ cnt))
)
(setq pts (mapcar (function (lambda (x)
(mapcar '+ x pt)
)
)
(reverse pts)
)
)
(entmake
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 no)
(cons 70 1)
(cons 43 0.0)
)
(mapcar (function (lambda (x)
(cons 10 x)
)
)
pts
)
)
)
)
;TesT :
(_entmake_polygonSeg '(0 0) 8 50.0)
~'J'~
-
Good job Fatty & a nice extra routine.
-
OK, here is a level 2 challenge.
Create the polygon so that one side is parallel to the x axis.
-
For the level 2 challenge:
(defun draw_polygon (cen nb rad flag / zdir elv n lst)
(setq zdir (trans '(0 0 1) 1 0 T)
elv (- (caddr cen) (caddr (trans '(0 0 0) 0 1)))
cen (list (car cen) (cadr cen) 0.0)
n nb
)
(if (= flag "Circumscribe")
(setq rad (/ rad (cos (/ pi nb))))
)
(if (= 1 (rem nb 2))
(setq ang (/ pi 2))
(setq ang (+ (/ pi 2) (/ pi nb)))
)
(repeat nb
(setq lst (cons (polar cen (+ ang (* (/ (* 2 pi) nb) (setq n (1- n)))) rad) lst))
)
(entmake
(append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 nb)
'(70 . 1)
(cons 38 elv)
(cons 210 zdir)
)
(mapcar '(lambda (pt) (cons 10 (trans pt 1 zdir))) lst)
)
)
)
(defun c:test (/ cen nb rad flag)
(setq cen (getpoint "\nCenter: ")
nb (getint "\nNumber of sides: ")
rad (getdist cen "\Radius: ")
)
(initget 1 "Inscribe Circumscribe")
(setq
flag (getkword "\nInscribe or Circumscribe ? [Inscribe/Circumscribe]: ")
)
(draw_polygon cen nb rad flag)
(princ)
)
-
First side and X axis are parallel:
(defun _entmake_polygon_XAxis (pt no rad flag / a da cnt pt pts rad x y)
(setq da (/ (* 2 pi) no)
rad (if flag
(/ rad (cos (/ pi no))) ;Circumscribe
rad ;Inscribe
)
cnt 0
sa (- (* 1.5 pi)(/ pi no))
a 0
)
(while (< cnt no)
(setq a (+ sa (* da cnt)))
(setq x (* rad (cos a))
y (* rad (sin a))
)
(setq pts (cons (list x y) pts))
(setq cnt (1+ cnt))
)
(setq pts (mapcar (function (lambda (x)
(mapcar '+ x pt)
)
)
(reverse pts)
)
)
(entmake
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 no)
(cons 70 1)
(cons 43 0.0)
)
(mapcar (function (lambda (x)
(cons 10 x)
)
)
pts
)
)
)
)
;TesT :
(_entmake_polygon_XAxis '(0 0) 9 50.0 nil);Inscribe
(_entmake_polygon_XAxis '(0 0) 9 50.0 t);Circumscribe
First side and Y axis are parallel:
(defun _entmake_polygon_YAxis (pt no rad flag / a da cnt pt pts rad x y)
(setq da (/ (* 2 pi) no)
rad (if flag
(/ rad (cos (/ pi no))) ;Circumscribe
rad ;Inscribe
)
cnt 0
sa (- pi (/ pi no))
a 0
)
(while (< cnt no)
(setq a (+ sa (* da cnt)))
(setq x (* rad (cos a))
y (* rad (sin a))
)
(setq pts (cons (list x y) pts))
(setq cnt (1+ cnt))
)
(setq pts (mapcar (function (lambda (x)
(mapcar '+ x pt)
)
)
(reverse pts)
)
)
(entmake
(append
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 no)
(cons 70 1)
(cons 43 0.0)
)
(mapcar (function (lambda (x)
(cons 10 x)
)
)
pts
)
)
)
)
;TesT :
(_entmake_polygon_YAxis '(0 0) 7 50.0 nil);Inscribe
(_entmake_polygon_YAxis '(0 0) 7 50.0 t);Circumscribe
~'J'~
-
Excellent solutions. You guy's are too fast. :)
-
Excellent solutions. You guy's are too fast. :)
...and nobody's using (command "_polygon")... :-)
-
Here is my revised version.
I must say I benefited form the fine examples already posted. :)
My first attempts were clumsy by comparison.
(defun mk_polygon (pt n rad ci? / ang ang1 lst)
(and ci? (setq rad (/ rad (cos (/ pi n)))))
(setq ang (/ pi (/ n 2.))
ang1 (+ (* pi 1.5) (/ ang 2))
)
(while (>= (setq n (1- n)) 0)
(setq lst (cons (cons 10 (polar pt (+ ang1 (* ang n)) rad)) lst))
)
(entmake
(append (list (cons 0 "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
(cons 70 1)
(cons 43 0.0)
(cons 38 0.0)
(cons 39 0.0)
)
lst
)
)
)
(defun c:test (/ cen nb rad flag)
(setq cen (getpoint "\nCenter: ")
nb (getint "\nNumber of sides: ")
rad (getdist cen "\Radius: ")
)
(initget "Inscribe Circumscribe")
(setq flag
(cond
((getkword "\nType ? [Inscribe/Circumscribe]: <Inscribe>"))
("Inscribe")))
(mk_polygon cen nb rad (= flag "Circumscribe"))
(princ)
)
-
Gile,
You seem to have a very good understanding of the coordinate system & the use of trans.
It would be beneficial to me and a number of folks here if you would share that knowledge in a
separate post of even an article on the subject.
Especially, "when you need it" and what commands & function need what type of trans.
I know that is a lot to ask as that type of post is very time consuming on your part, so if
it not something you have time for I'll / we will keep learning from the code you post.
Thanks for your examples.
-
Gile,
Just to clarify, I am talking about an "Over View" of the application of trans. :-)
-
This version provide the ability to align a specific side with the x or y axis.
;; CAB version2 11/15/2006
;; Arguments:
;; pt center point
;; n number of sides
;; rad radius of circle
;; ci? t/nil Cercumscribe/Inscribe on the circle
;; align string, side with xTop or xBottom or yRight or yLeft
;; lay string, layer name
;; clr color number
(defun mk_polygon (pt n rad ci? align lay clr / ang ang1 lst)
(setq ang (/ pi (/ n 2.0))
align (strcase align))
(cond
((= align "XBOTTOM")
(setq ang1 (+ (* pi 1.5) (/ ang 2)))
)
((= align "XTOP")
(setq ang1 (+ (* pi 1.5) (/ ang 2) pi))
)
((= align "YRIGHT")
(setq ang1 (+ (/ ang 2)))
)
((= align "YLEFT")
(setq ang1 (+ (/ ang 2) pi))
)
(t (setq ang1 0))
)
(and ci? (setq rad (/ rad (cos (/ pi n)))))
(while (>= (setq n (1- n)) 0)
(setq lst (cons (cons 10 (polar pt (+ ang1 (* ang n)) rad)) lst))
)
(entmake
(append (list (cons 0 "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 8 lay)
(cons 90 (length lst))
(cons 70 1) ; 0= open 1= closed
(cons 43 0.0)
(cons 38 0.0)
(cons 39 0.0)
(cons 62 clr) ; color bylayer
)
lst
)
)
)
(defun c:test2(/ wait ss)
(defun wait (prm) (getstring (if prm prm "\nPress enter to continue")))
(setq ss (ssadd))
(mk_polygon '(0.0 0.0 0.0) 5 5 t "xTop" "0" 1)
(ssadd (entlast) ss)
(wait "\nxTop")
(mk_polygon '(0.0 0.0 0.0) 5 5 t "xBottom" "0" 2)
(ssadd (entlast) ss)
(wait "\nxBottom")
(mk_polygon '(0.0 0.0 0.0) 5 5 nIL "yRight" "0" 3)
(ssadd (entlast) ss)
(wait "\nyRight")
(mk_polygon '(0.0 0.0 0.0) 5 5 nil "yLeft" "0" 4)
(ssadd (entlast) ss)
(wait "\nyLeft")
(mk_polygon '(0.0 0.0 0.0) 5 5 nil "xy45R" "0" 5)
(ssadd (entlast) ss)
(wait "\nxy45R")
(mk_polygon '(0.0 0.0 0.0) 5 5 nil "xy45L" "0" 6)
(ssadd (entlast) ss)
(wait "\nxy45L")
(command "._erase" ss "")
(princ)
)
-
Thanks, Alan I have learned something new
from you again. :-)
Nice one
>'J'<
-
Nice one Alan, but still don't work in UCSs non parallel to WCS ;-)
I let you try before giving a solution.
-
Gile,
Will this do it?
I just used you code example. :)
This version must be supplied with a angle in degrees or the alignment.
It will allow more flexibility in determining which side to align.
;; CAB version3 11/15/2006
;;
;; Arguments:
;; pt center point
;; n number of sides
;; rad radius of circle
;; ci? t/nil Cercumscribe/Inscribe on the circle
;; align angle in degrees to align a side
;; 0= x-axis bottom 180= x-axis top
;; 90= y-axis right 270= y-axis left
;; so 0-179 is bottom & right
;; while 180-359 is top & left
;; lay string, layer name
;; clr color number
(defun mk_polygon (pt n rad ci? align lay clr / ang ang1 lst)
(setq zdir (trans '(0 0 1) 1 0 T)
elv (- (caddr pt) (caddr (trans '(0 0 0) 0 1)))
pt (list (car pt) (cadr pt) 0.0)
)
(setq ang (/ pi (/ n 2.0)))
(setq ang1 (+ (/ (* align pi) 180.0) (* pi 1.5) (/ ang 2)))
(and ci? (setq rad (/ rad (cos (/ pi n)))))
(while (>= (setq n (1- n)) 0)
(setq lst (cons (cons 10 (trans (polar pt (+ ang1 (* ang n)) rad) 1 zdir)) lst))
)
(entmake
(append (list (cons 0 "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 8 lay)
(cons 90 (length lst))
(cons 70 1) ; 0= open 1= closed
(cons 43 0.0)
(cons 38 elv)
(cons 39 0.0)
(cons 62 clr) ; color bylayer
(cons 210 zdir)
)
lst
)
)
)
(defun c:test3(/ wait ss)
(defun wait (prm) (getstring (if prm prm "\nPress enter to continue")))
(setq ss (ssadd))
(mk_polygon '(0.0 0.0 10.0) 5 5 t 180 "0" 1)
(ssadd (entlast) ss)
(wait "\nxTop")
(mk_polygon '(0.0 0.0 10.0) 5 5 t 0 "0" 2)
(ssadd (entlast) ss)
(wait "\nxBottom")
(mk_polygon '(0.0 0.0 10.0) 5 5 nIL 90 "0" 3)
(ssadd (entlast) ss)
(wait "\nyRight")
(mk_polygon '(0.0 0.0 10.0) 5 5 nil 270 "0" 4)
(ssadd (entlast) ss)
(wait "\nyLeft")
(mk_polygon '(0.0 0.0 10.0) 5 5 nil 45 "0" 5)
(ssadd (entlast) ss)
(wait "\nxy45R")
(mk_polygon '(0.0 0.0 10.0) 5 5 nil 225 "0" 6)
(ssadd (entlast) ss)
(wait "\nxy45L")
(mk_polygon '(0.0 0.0 10.0) 5 5 t 135 "0" 1)
(ssadd (entlast) ss)
(wait "\nxy135R")
(mk_polygon '(0.0 0.0 10.0) 5 5 t 315 "0" 2)
(ssadd (entlast) ss)
(wait "\nxy135L")
(command "._erase" ss "")
(princ)
)
-
Yes, it works fine !:-)
The code I posted, was made of lines from other codes :|, it would have been more concise :
(setq zdir (trans '(0 0 1) 1 0 T)
elv (caddr (trans pt 1 zdir))
)
rather than :
(setq zdir (trans '(0 0 1) 1 0 T)
elv (- (caddr pt) (caddr (trans '(0 0 0) 0 1)))
pt (list (car pt) (cadr pt) 0.0)
)
-
So pt does not have to be transed again until the trans in the polar?
-
No, (trans (polar pt (+ ang1 (* ang n)) rad) returns points around pt in UCS which, then, are transed in OCS.
In the other topic (http://www.theswamp.org/index.php?topic=13526.0) I "explained" how to get the USC plane elevation using (caddr (trans '(0 0 0) 1 zdir)), replacing '(0 0 0) by pt will add pt Z coordinate to the plane elevation.
I'll post there an example to make lwpolylines whatever UCS with entmake and vlax-invoke.