[转贴]：一堆 Lisp 函数

eachy · 发表于 2003-11-23 00:07:02

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;;; FAQ-CODE.LSP
;;;; Code from the comp.cad.autocad AutoLISP FAQ
;;;; (c) 1991-1997 Reini Urban <rurban@x-ray.at>
;;;;
;;;; This code may only be redistributed together with the FAQ document.
;;;; The FAQ may be freely redistributed in its entirety without
;;;; modification provided that this copyright notice is not removed. It
;;;; may not be sold for profit or incorporated in commercial documents
;;;; (e.g. published for sale on CD-ROM, floppy disks, books, magazines,
;;;; or other print form) without the prior written permission of the
;;;; copyright holder. Permission is expressly granted for this document
;;;; to be made available for file transfer from installations offering
;;;; unrestricted anonymous file transfer on the Internet and to be
;;;; included into the official AutoCAD FAQ.
;;;;
;;;; These functions are, if not otherwise stated, (c) 1991-97
;;;; by Reini Urban and may be freely used. If you include some of those
;;;; functions in your code, you have to add a short line if you intend
;;;; to ship source code or a seperate document to your program where to
;;;; find the FAQ and this code.
;;;;
;;;; This code is provided AS IS without any expressed or implied warranty.
;;;;
;;;; If you intentionally got this copy without the FAQ, get the FAQ at
;;;; [url]http://xarch.tu-graz.ac.at/autocad/news/faq/autolisp.html[/url]
;;;;-----------------------------------------------------------------------
;;;;
;;;; These are some basic AutoLISP functions to make life, faq-writing
;;;; and posting news-answers easier. For more see /autocad/stdlib/
;;;;
;;;; Last update: 6.Dec 99
;;;;
;;;; Version 2.2 13.Jul 99 renamed ssapply to ssmap
;;;; Version 2.0 11.May 98 fixed: arc2bul, ddecmd, tan
;;;; Version 1.10 22.July 97 LWPOLYLINE support and fixes
;;;; Version 1.9 26.June 97 pline-segs, ddecmd, getval
;;;; Version 1.8 15.May 97 R14 fixes, ssapply
;;;; Version 1.71 7.May 97 added (dxf)
;;;;
;;;;-----------------------------------------------------------------------
;;;; [3.3] You may include break functions and debug print into your source
;;;; code.
;;; Debugging functions
(defun break (s)
(if *BREAK*
(progn
(princ "BREAK>> (stop with <Enter>)\nBREAK>> ")
(princ s)
(while (/= (setq s (getstring "\nBREAK>> ")) "")
(print (eval (read s)))
)
)
)
) ;bugfix from v1.3!
(defun dbg-print (s) ;accepts atoms and lists
(if *DEBUG*
(if (listp s)
(mapcar 'print s)
(print s)
)
)
)
(defun C:DEBUG () (setq *DEBUG* (not *DEBUG*))) ;switch it on and off
(defun C:BREAK () (setq *BREAK* (not *BREAK*)))
(defun CONT () (setq *BREAK* nil)) ;cont. without any interruption
;;;;[15] How can I pass a variable number of arguments to a lisp function?
;;; MY-PRINC - print a variable number of arguments (of any type)
(defun my-princ (x)
;; simple version, for better stuff look at the SDK2: PRINTF.LLB
(if (listp x)
(mapcar 'princ x)
(princ x)
)
)
;;;; [16] How can I avoid stack overflows?
;;; INTLST - create '(0 1 2 ... n)
(defun intlst (n / l)
(repeat n
(setq l (cons (setq n (1- n)) l))
)
) ;this looks ugly but it works
;;;; [20] general Helper functions
;;; DXF - return the DXF group code of an (entget) list
(defun dxf (grp ele) (cdr (assoc grp ele)))
;;;; [20.1] List manipulation
;;; CONSP - a not empty list
(defun consp (x) (and x (listp x)))
;;; POSITION - returns the index of the first element in the list,
;;; base 0, or nil if not found
;;; (pos x '(a b c)) -> nil, (pos b '(a b c d)) -> 1
(defun position (x lst / ret)
(if (not (zerop (setq ret (length (member x lst)))))
(- (length lst) ret)
)
)
;;; REMOVE - Removes an item from a list (double elements allowed)
;;; (remove 0 '(0 1 2 3 0)) -> (1 2 3)
(defun remove (ele lst) ; by Serge Volkov
(apply 'append (subst nil (list ele) (mapcar 'list lst)))
)
;;; REMOVE-IF - Conditional remove from flat list,
;;; pred requires exactly 1 arg
;;; (remove-if 'zerop '(0 1 2 3 0)) -> (1 2 3)
;;; (remove-if 'numberp '(0 (0 1) "")) -> ((0 1) "")
(defun remove-if (pred from)
(cond
((atom from) from) ;nil or symbol (return that)
((apply pred (list (car from))) (remove-if pred (cdr from)))
(t (cons (car from) (remove-if pred (cdr from))))
)
)
;;; REMOVE-IF-NOT - keeps all elements to which the predicate applies
;;; say: "keep if", it need not be defined recursively, also like this
(defun remove-if-not (pred lst) ; by Vladimir Nesterowsky
(apply 'append
(mapcar '(lambda (e)
(if (apply pred (list e))
(list e)
)
)
lst
)
)
)
;;; ADJOIN - conses ele to list if not already in list
;;; trick: accepts quoted lists too, such as
;;; (setq l '(1 2 3) (adjoin 0 'l)
;;; -> !l (0 1 2 3)
(defun adjoin (ele lst / tmp)
(if (= (type lst) 'SYM)
(setq tmp lst
lst (eval tmp)
)
)
(setq lst (cond ((member ele lst) lst)
(t (cons ele lst))
)
)
(if tmp
(set tmp lst)
lst
)
)
;;; ROT1 - put the first element to the end, simple version
;;; Say "rotate by one" or "rotate left"
(defun rot1 (lst) (append (cdr lst) (list (car lst))))
;;; BUTLAST - the list without the last element
(defun butlast (lst)
(reverse (cdr (reverse lst)))
)
;;;; [20.2] string predicates
;;; STRINGP - string predicate: "is s a string?"
(defun stringp (s)
(= (type s) 'STR)
)
;;; STRING-NOT-EMPTYP - is str a not empty string?
(defun string-not-emptyp (s)
(and (stringp s) (/= s ""))
)
;;; for more list and string manipulation code see
;;; AI_UTILS.LSP or
;;; [url]ftp://xarch.tu-graz.ac.at/pub/autocad/lisp/lisp.lsp[/url] and string.lsp
;;; or at [url]http://xarch.tu-graz.ac.at/autocad/code/vnestr/strtok.lsp[/url]
;;;; [20.3] symbol->string
;;; SYMBOL-NAME - returns the name of a symbol as string
;;; converts any valid lisp expression to its printed representation
;;; (symbol-name a) -> "a", (symbol-name '(0 1 2 a)) -> "(0 1 2 A)"
(defun symbol-name (sym / f str tmp)
(setq tmp "$sym.tmp") ;temp. filename, should be deleted
(setq f (open tmp "w"))
(princ sym f)
(close f)
(setq f (open tmp "r")
str (read-line f)
f (close f)
)
str
)
;;;; [20.4] AutoCAD entity access
;;; GETVAL - returns the group value of an entity.
;;; like the wellknown (dxf) function but accepts all kinds of
;;; entity representations (ename, entget list, entsel list)
(defun GETVAL (grp ele) ;"dxf value" of any ent...
(cond ((= (type ele) 'ENAME) ;ENAME
(cdr (assoc grp (entget ele)))
)
((not ele) nil) ;empty value
((not (listp ele)) nil) ;invalid ele
((= (type (car ele)) 'ENAME) ;entsel-list
(cdr (assoc grp (entget (car ele))))
)
(T (cdr (assoc grp ele)))
)
) ;entget-list
;;; Ex: (gettyp pline) => "POLYLINE"
(defun GETTYP (ele) ;return type
(getval 0 ele)
)
;;; ENTITY - assure ENAME
;;; convert the entity to type ENAME (to write shorter code)
(defun ENTITY (ele) ;convert to element name
(cond ;accepts the following types:
((= (type ele) 'ENAME) ele) ; ENAME
((not (listp ele)) nil) ; error: no list
((= (type (car ele)) 'ENAME) (car ele)) ; entsel-list
((cdr (assoc -1 ele))) ; entget-list or nil
)
)
;and now just: (defun getval (grp ele) (cdr (assoc grp (entget (entity ele)))))
;;; Ex: (istypep ele "TEXT")
;;; is element a "SOLID"?
(defun istypep (ele typ) ;check type
(= (gettyp ele) typ)
)
;;; Ex: (istypep ele '("TEXT" "ATTDEF"))
;;; is element a "TEXT" or a "ATTDEF"?
(defun ISTYPEP (ele typ) ;better implementation to accept lists too
(cond
((listp typ) (member (gettyp ele) typ))
((stringp typ) (= (gettyp ele) typ));assume typ uppercase, wcmatch is slower but neater
(T nil)
)
)
;;; Ex: (getpt (entsel)) => ( 0.1 10.0 24)
(defun GETPT (ele) ;return the startpoint of any element
(getval 10 ele)
) ;group 10
;;; Ex: (getflag pline) => 1 if closed
(defun GETFLAG (ele) (getval 70 ele)) ;same with the entity flag
;;; FLAGSETP - bitvalue val in flag of element set?
;;; Ex: (flagsetp 1 pline) => T if closed
;;; Ex: (flagsetp 16 vertex) => T if spline control point
(defun FLAGSETP (val ele)
(bitsetp val (getflag ele))
)
;;; Ex: (bitsetp 4 12) => T ;bitvalue 4 (=2.Bit) in 12 (=4+8) is set
(defun BITSETP (val flag)
(= (logand val flag) val)
)
;;; SSLIST - convert selection set to list. slow, but easy to write.
;;; Note: it's also wise to use ai_ssget, because some ents could be
;;; on locked layers
;;; Ex: (sslist (ai_ssget (ssget))) => list of selected unlocked ents
;;; or (mapcar 'entupd (sslist (ssget "X" '((8 . "TEMP")))))
;;; - regens all entities on layer TEMP
(defun SSLIST (ss / n lst)
(if (= 'PICKSET (type ss))
(repeat (setq n (sslength ss))
(setq n (1- n)
lst (cons (ssname ss n) lst)
)
)
)
)
;;; SSMAP - apply a function to each ent in ss, in reversed order
;;; Faster, but not so easy to understand. see [22.2] Datestamp
;;; [renamed from SSAPPLY to SSMAP to match the stdlib name]
;;; Ex: (ssmap 'entupd (ssget)) ; regenerate only some entities
(defun SSMAP (fun ss / n)
(if (= 'PICKSET (type ss))
(repeat (setq n (sslength ss))
(apply fun (list (ssname ss (setq n (1- n)))))
)
)
)
;;; backwards compatibility alias:
(setq ssapply ssmap)
;;; [21.2] Plot dialog from within Lisp. Using DDE
;;; R13 code! For R12 use "autocad.dde" as the server name. Then, inside your lisp
;;; or script, you can do (ddecmd "_plot "). Function DDECMD will return
;;; nil if something wrong, or the string you passed if successful. The
;;; string is just like what you type under the command prompt from
;;; keyboard, so you need put a space or a return, which is "^13" here,
;;; to end the string.
;;; Besides, the function is very useful in the following situation: If
;;; within a lisp, you need call an AutoCAD transparent command like
;;; LAYER, normally you will use (command "_layer"), but after use this
;;; line, the lisp own will not be transparent. Using the function, you
;;; will solve this problem.
;;; [fixed for all releases]
(defun DDECMD (str / tmp acadver ddestr)
(if (not (boundp 'initiate))
(cond
((= 14 (setq acadver (atoi (getvar "ACADVER"))))
(setq ddestr "AutoCAD.R14.DDE")
(arxload "ddelisp")
)
((= 13 acadver)
(setq ddestr "autocad.r13.dde")
(xload "ddelisp")
)
((= 12 acadver)
(setq ddestr "autocad.dde")
(xload "ddelisp")
)
(T (princ "DDE not supported") (exit))
)
)
(if (not (zerop (setq tmp (initiate ddestr "system"))))
(progn
(execute tmp (strcat "[" str "]"))
(terminate tmp)
str
)
)
)
;;; Visual Lisp Example:
;|
(setq vlax:ActiveDocument (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(setq plt (vla-get-plot vlax:ActiveDocument)) ;=> plot object
(vla-PlotWindow plt pt1 pt2) ; define window (pts in WCS)
(vla-PlotPreview plt 1) ; 0 for partial, 1 for full
(vla-PlotToDevice plt "Default System Printer") ; if it exists
|;
;;;; [21.3] (entmod) and (entmake) Layers, without (command "_LAYER"...)
;;; This sample routine will create a layer with any name you type:
;;; by Reinaldo Togores <rtogores@mundivia.es>
(defun C:MLAY ()
(setq laynam (getstring "\nLayer name: "))
(entmake
(list
'(0 . "LAYER")
'(5 . "28")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
(cons 2 laynam)
'(70 . 64)
'(62 . 7)
'(6 . "CONTINUOUS")
)
)
)
;;;; [21.6] (vports), VIEWPORT entity, pixel conversion
;;; Conversion pixel to drawing units
(defun pix2units (pix)
(* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
)
;;; Conversion drawing units to pixel
(defun units2pix (units)
(* units
(/ (cadr (getvar "SCREENSIZE")) (getvar "VIEWSIZE"))
)
)
;;;;[21.7] Select all visible objects: zoom coordinates
;;; returns a list of the actual viewport corners in WCS
(defun zoompts (/ ctr h screen ratio size size_2)
(setq ctr (xy-of (getvar "VIEWCTR")) ;3D -> 2D
h (getvar "VIEWSIZE") ;real
screen (getvar "SCREENSIZE") ;2D: Pixel x,y
ratio (/ (float (car screen)) ;aspect ratio
(cadr screen)
)
size (list (* h ratio) h) ;screensize in coords
size_2 (mapcar '/ size '(2.0 2.0))
)
(list (mapcar '- ctr size_2)
(mapcar '+ ctr size_2)
)
)
(defun xy-of (pt) (list (car pt) (cadr pt))) ;assure 2D coords
;;; returns all visible entities as a selection set
;;; one way to define this function
(defun ssall-visible (/ l)
(ssget "C" (car (setq l (maptrans0-1 (zoompts)))) (cadr l))
)
;;; or another
(defun ssall-visible-1 () ;combine "C" and (p1 p2) to one list
(apply 'ssget (append '("C") (maptrans0-1 (zoompts))))
)
;;; map some pts from WCS to UCS, easier with just one argument
(defun maptrans0-1 (pts)
(mapcar '(lambda (pt) (trans pt 0 1)) pts)
)
;;;; [21.8] How to write XYZ data of selected objects to a file?
;;; CDF - comma delimited string
(defun cdf-point (pt)
(strcat (car pt) ", " (cadr pt) ", " (caddr pt))
)
;;; SDF - space delimited, may easier be read back in to AutoCAD
(defun sdf-point (pt)
(strcat (car pt) " " (cadr pt) " " (caddr pt))
)
;;; convert this SDF format back to a point with
(defun str->point (s)
(eval (read (strcat "(" s ")")))
)
;;; Write a XYZ file of all selected objects (SDF see below)
(defun C:XYZ (/ ss fname f)
(if (and (setq ss (ssget))
(setq fname (getfiled "Write XYZ to file"
(strcat (getvar "DWGNAME") ".XYZ")
"XYZ"
7
)
)
(setq f (open fname "w"))
)
(foreach ele (sslist ss) ; -> [20.4]
(foreach pt (getpts ele) ; -> [23.1]
(write-line (cdf-point pt) f)
)
)
)
(if f
(close f)
)
)
;;; => <fname>.xyz
;;; 0.45, 12.3, -34.0
;;; For a ASC file (SDF-format) simply change all XYZ to ASC
;;; and cdf-point to sdf-point above.
(defun C:ASC (/ ss fname f)
(if (and (setq ss (ssget))
(setq fname (getfiled "Write ASC to file"
(strcat (getvar "DWGNAME") ".ASC")
"ASC"
7
)
)
(setq f (open fname "w"))
)
(foreach ele (sslist ss) ; -> [20.4]
(foreach pt (getpts ele) ; -> [23.1]
(write-line (sdf-point pt) f)
)
)
)
(if f
(close f)
)
)
;;;; [22] Block Attributes
;;; ATTELE - returns entget-list of attribute attname (STRING) in element
;;; ele or nil if not found
(defun attele (ele attname / rslt)
(if (and (istypep ele "INSERT")
(= (getval 66 ele) 1)
)
(progn
(setq ele (entnext (entity ele)))
(while (and ele (istypep ele "ATTRIB"))
(if (= (strcase (getval 2 ele)) (strcase attname))
(setq rslt (entget ele)
ele nil
) ;break the loop
(setq ele (entnext ele))
)
)
)
)
rslt
)
;;; ATTCHG - change the attribute value of INSERT ele to new (group 1)
(defun attchg (ele attname new / b)
(if (setq b (attele ele attname))
(entmod (subst (cons 1 new) (getval 1 b) b))
)
)
;;; Change all DATESTAMP attributes in all inserted PLOT* blocks
(defun C:DATESTAMP ()
(ssmap
'(lambda (ele)
(attchg ele "DATESTAMP" (today))
(entupd ele)
)
(ssget "X" '((0 . "INSERT") (2 . "PLOT*")))
)
)
;;; TODAY - return todays date, could be a DIESEL or this string conversion
;;; with DIESEL it's easier to define it according your format (i.e day of week)
(defun today (/ s)
(setq s (rtos (getvar "CDATE") 2)) ;gets the julian date
(strcat (substr s 5 2)
"-"
(substr s 7 2)
"-"
(substr s 3 2)
)
)
;;; MAIN-ENTITY - some more helper funcs to get the main entity of any attribute
;;; or vertex
(defun main-entity (ele)
(setq b (entity b)) ;force ENAME
(while (istypep b '("ATTRIB" "ATTDEF" "VERTEX"))
(setq b (entnext b))
) ;loop until no more sub-ents
(if (istypep b '("SEQEND" "ENDBLK"))
(getval -2 b) ;complex entity -> header
b ;normal entity
)
)
;;;; [23] Polylines
;;; return only some assoc values in the list (for LWPOLYLINE)
(defun GROUP-ONLY (grp lst)
(mapcar 'cdr
(remove-if-not '(lambda (pair) (= grp (car pair))) lst)
)
)
;;; return the vertex list of a polyline or of any other element
;;; Note that with edlgetent mentioned in [22.1] it's a one-liner
(defun GETPTS (ele / pts)
(setq ele (entity ele)) ;force type ENAME
(cond
((istypep ele "POLYLINE")
(while (istypep (setq ele (entnext ele)) "VERTEX")
;; omit fit and spline points (conservative style)
(if (not (or (flagsetp 1 ele) (flagsetp 8 ele))) ;bugfix!
(setq pts (cons (trans (getpt ele) ele 0) pts))
)
(reverse pts)
)
)
;; Special case: you have to map it, assoc finds only the first.
;; Fix a LWPOLYLINE bug in R14: internally stored as 2d point,
;; (entget) returns fantasy z-values.
((istypep ele "LWPOLYLINE")
(mapcar '(lambda (pt) (trans (list (car pt) (cadr pt) 0.0) ele 0))
(group-only 10 (entget ele))
)
)
;; insert here possible other types, such as
((istypep ele '("TEXT" "CIRCLE")) (list (getpt ele)))
;; more like this (serge's style)
(T
(apply 'append
(mapcar
'(lambda (n / p)
(if (setq p (getval n ele))
(list p)
)
)
'(10 11 12 13)
)
)
)
;; or like this (conservative style)
;;(T (foreach n '(10 11 12 13)
;; (if (setq p (getval n ele)) (setq pts (cons p pts))))
;; pts
;;)
)
)
;;; This sample converts all selected elements to polylines and
;;; tries to join as much as possible.
(defun C:JOINPOLY (/ ele ss)
(foreach ele (sslist (setq ss (ssget))) ;better process lists
(if (entget ele) ;not already joined
(cond ;(then it would be nil)
((istypep ele '("ARC" "LINE"))
;; in fact you should check Z of lines and UCS here too
(command "_PEDIT" ele "_Y" "_J" ss "" "") ; convert and JOIN
)
((and (istypep ele '("POLYLINE" "LWPOLYLINE")) ;bugfix
(not (flagsetp 1 ele)) ;not closed
(< (rem (getflag ele) 128) 8)
) ;ignore meshes and such
(command "_PEDIT" ele "_J" ss "" "") ;ucs check omitted
)
)
)
)
)
;;; Sets new polywidth for multiple plines
(defun C:POLYWID (/ wid ele)
(initget 5)
(setq wid (getdist "New Polyline Width: ")) ;not negative
(foreach ele (sslist (ssget '((0 . "*POLYLINE")))) ;only PLINES
(command "_PEDIT" ele "_W" wid "")
)
)
;;; Draws a POLYLINE entity from a list of points (same with SPLINE,
;;; or LINE), on the actual UCS, with actual OSNAP settings
(defun draw-pline (pts)
(command "_PLINE")
(mapcar 'command pts)
(command "")
)
(defun draw-spline (pts)
(command "_SPLINE")
(mapcar 'command pts) ; the pts must be the fitpoints then
(command "" "" "")
)
;;; add up the LENGTH of all selected objects, NOISY, you can do the
;;; same with AREAs: simply change the last line to (getvar "AREA")
(defun C:LEN-OF ()
(command "_AREA" "_A" "_E") ;add up objects (R12+13)
(ssmap 'command (ssget)) ;pass all elements to AutoCAD
(command "" "") ;two returns
(getvar "PERIMETER")
) ;this is the length
;;; calculates length of a pline, quiet
(defun POLY-LENGTH (poly / seg)
(apply '+ ; the sum of all single segment lengths
(mapcar
'(lambda (seg) ;length of one segment
(if (zerop (car seg)) ;is it straight?
(distance (cadr seg) (caddr seg)) ; line segment or
(abs (arclen seg))
)
) ; curved: -> [24]
(pline-segs poly)
)
)
) ;segment list (bulge p1 p2)
;;; returns all group codes of the complex element
;;; (vertices, attributes) as list, similar to (edlgetent)
(defun CPLX-LIST (grp ele / lst)
(if (= 1 (getval 66 ele))
(progn (setq ele (entnext (entity ele)))
(while (and ele (not (istypep ele "SEQEND")))
(setq lst (cons (getval grp ele) lst)
ele (entnext ele)
)
)
(reverse lst)
)
)
)
;;; PLINE-SEGS - Creates a segment list for the polyline pname
;;; as a list of '(bulge p1 p2). A straight line has bulge 0.0
;;; Compute pts in ECS of pname. Accepts LWPOLYLINE's
(defun pline-segs (pname / pts segs)
(setq segs
(mapcar 'list
(if (istypep pname "LWPOLYLINE")
(group-only 42 (entget pname))
(cplx-list 42 pname)
)
(setq pts (getpts pname)) ; ->[23.1]
(rot1 pts)
)
) ; ->[20.1]
(if (flagsetp 1 pname)
segs ;closed
(butlast segs)
)
) ;open: without the last segment, ->[20.1]
;;; Example: (a bit optimized for brevity :)
;;; Add up all the lengths of all selected polylines, quiet
;;; To accept also other entities, add those to pline-segs
(defun C:POLYLEN ()
(apply '+ (ssmap 'poly-length (ssget '((0 . "*POLYLINE")))))
)
;;;; [24] Circle/Arc Geometry: BULGE conversion, some trigonometry
;;; SEG2CIR - converts a bulged segment (bulge pt1 pt2) of a polyline
;;; to a circle (ctr rad), the start- and endpoints are known
;;; therefore the angles too: (angle ctr pt1)(angle ctr pt2)
;;; returns nil on a straight segment!
(defun seg2cir (seg / bulge p1 p2 cot x y rad dummy)
(if (zerop (car seg)) ;straight line => invalid circle
nil
(setq bulge (car seg)
p1 (cadr seg)
p2 (caddr seg)
cot (* 0.5 (- (/ 1.0 bulge) bulge))
x (/ (- (+ (car p1) (car p2)) (* (- (cadr p2) (cadr p1)) cot))
2.0
)
y (/ (+ (+ (cadr p1) (cadr p2)) (* (- (car p2) (car p1)) cot))
2.0
)
rad (distance (list (car p1) (cadr p1)) (list x y))
dummy (list (list x y) rad) ; return this, I hate progn's
)
)
)
;;; ARC2SEG - inverse conversion:
;;; calculates segment (bulge p1 p2) of arc
;;; with given circle (ctr rad), start-angle, end-angle
;;; (arc2seg cir (angle (car cir) p1) (angle (car cir) p2)) =>seg
(defun arc2seg (cir ang1 ang2 / p1 p2)
(setq p1 (polar (car cir) ang1 (cadr cir))
p2 (polar (car cir) ang2 (cadr cir))
)
(list (arc2bul p1 p2 cir) p1 p2)
)
;;; ARC2BUL - calculates bulge of arc given the arc points and the
;;; circle (ctr rad) [fixed by Serge Pashkov]
(defun arc2bul (p1 p2 cir / ang)
(setq ang (- (angle (car cir) p2) (angle (car cir) p1)))
(if (minusp ang)
(setq ang (+ (* 2.0 pi) ang))
)
(tan (/ ang 4.0))
)
;;; BUL2ANG - returns inner angle of arc (bulge)
(defun bul2ang (seg / ctr)
(- (angle (setq ctr (car (seg2cir seg))) (cadr seg))
(angle ctr (caddr seg))
)
)
;;; ARC2ANG
;;; calculates angle of arc given the chord distance and radius
(defun arc2ang (chord rad)
(* 2.0
(atan
(/ chord
2.0
(sqrt (- (expt rad 2)
(expt (/ chord 2.0) 2)
)
)
)
)
)
)
;;; ARCLEN - length of arc = radius*angle,
;;; Note: +-, you'll need (abs (arclen seg))
(defun arclen (seg)
(* (cadr (seg2cir seg)) ; radius
4.0
(atan (car seg))
)
) ; angle = 4*atan(bulge)
(setq *INFINITY* 1.7e308) ; largest double
(defun tan (z / cosz) ; [fixed]
(if (zerop (setq cosz (cos z)))
*INFINITY*
(/ (sin z) cosz)
)
)
(defun dtr (ang) (* pi (/ ang 180.0))) ; degree to radian
(defun rtd (ang) (/ (* ang 180.0) pi)) ; radian to degree
;;;;[26] EED Extended Entity Data: Select, Get and Store
;;; here is how to get the eed list from one element for all regapps
(defun get-eedlist-all (ele)
(cdadr (assoc -3 (entget (entity ele) '("*"))))
)
;;; this gets all elements of appnames rname (wildcards allowed)
(defun ssget-app (rname)
(ssget "X" (list (list -3 (list rname))))
)
;;; Check any XDATA with: (entget (car (entsel)) '("*"))
;;; GETXDATA - get all XDATA lists from an element
;;; i.e with XDATA:
;;; (-3 ("HUBU-1" (1000 ."ASSHATCH")(1002 ."{")
;;; (1070 . 1)(1002 ."}")))
;;; =>(("HUBU-1" (1000 ."ASSHATCH")(1002 ."{")(1070 . 1)(1002 ."}")))
(defun getxdata (e apnlst)
(cdr (assoc -3 (entget e apnlst)))
)
;;; GETXDATA-ALL - all lists without the regapp name
;;; => ((1000 ."ASSHATCH")(1002 ."{")(1070 . 1)(1002 ."}"))
(defun getxdata-all (e apnlst)
(apply 'append (mapcar 'cdr (getxdata e apnlst)))
)
;;; Conversion pixel to drawing units
(defun PIX2UNITS (pix)
(* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))
)
;;; Conversion drawing units to pixel
(defun UNITS2PIX (units)
(* units
(/ (cadr (getvar "SCREENSIZE")) (getvar "VIEWSIZE"))
)
)

;;;; FAQ-CODE.LSP 
;;;; Code from the comp.cad.autocad AutoLISP FAQ 
;;;; (c) 1991-1997 Reini Urban  <rurban@x-ray.at> 
;;;; 
;;;; This code may only be redistributed together with the FAQ document. 
;;;; The FAQ may be freely redistributed in its entirety without 
;;;; modification provided that this copyright notice is not removed. It 
;;;; may not be sold for profit or incorporated in commercial documents 
;;;; (e.g. published for sale on CD-ROM, floppy disks, books, magazines, 
;;;; or other print form) without the prior written permission of the 
;;;; copyright holder. Permission is expressly granted for this document 
;;;; to be made available for file transfer from installations offering 
;;;; unrestricted anonymous file transfer on the Internet and to be 
;;;; included into the official AutoCAD FAQ. 
;;;; 
;;;; These functions are, if not otherwise stated, (c) 1991-97 
;;;; by Reini Urban and may be freely used. If you include some of those 
;;;; functions in your code, you have to add a short line if you intend 
;;;; to ship source code or a seperate document to your program where to 
;;;; find the FAQ and this code. 
;;;; 
;;;; This code is provided AS IS without any expressed or implied warranty. 
;;;; 
;;;; If you intentionally got this copy without the FAQ, get the FAQ at 
;;;;   [url]http://xarch.tu-graz.ac.at/autocad/news/faq/autolisp.html[/url] 
;;;;----------------------------------------------------------------------- 
;;;; 
;;;; These are some basic AutoLISP functions to make life, faq-writing 
;;;; and posting news-answers easier. For more see /autocad/stdlib/ 
;;;; 
;;;; Last update: 6.Dec 99 
;;;; 
;;;; Version 2.2     13.Jul 99                    renamed ssapply to ssmap 
;;;; Version 2.0     11.May 98                    fixed: arc2bul, ddecmd, tan 
;;;; Version 1.10    22.July 97                   LWPOLYLINE support and fixes 
;;;; Version 1.9     26.June 97                   pline-segs, ddecmd, getval 
;;;; Version 1.8     15.May 97                    R14 fixes, ssapply 
;;;; Version 1.71    7.May 97                     added (dxf) 
;;;; 
;;;;----------------------------------------------------------------------- 
 
 
;;;; [3.3] You may include break functions and debug print into your source 
;;;;       code. 
 
;;; Debugging functions 
(defun break (s) 
  (if *BREAK* 
    (progn 
      (princ "BREAK>> (stop with <Enter>)\nBREAK>> ") 
      (princ s) 
      (while (/= (setq s (getstring "\nBREAK>> ")) "") 
        (print (eval (read s))) 
      ) 
    ) 
  ) 
)                                        ;bugfix from v1.3! 
(defun dbg-print (s)                        ;accepts atoms and lists 
  (if *DEBUG* 
    (if        (listp s) 
      (mapcar 'print s) 
      (print s) 
    ) 
  ) 
) 
(defun C:DEBUG () (setq *DEBUG* (not *DEBUG*))) ;switch it on and off 
(defun C:BREAK () (setq *BREAK* (not *BREAK*))) 
(defun CONT () (setq *BREAK* nil))        ;cont. without any interruption 
 
 
;;;;[15] How can I pass a variable number of arguments to a lisp function? 
 
;;; MY-PRINC  - print a variable number of arguments (of any type) 
(defun my-princ        (x) 
  ;; simple version, for better stuff look at the SDK2: PRINTF.LLB 
  (if (listp x) 
    (mapcar 'princ x) 
    (princ x) 
  ) 
) 
 
;;;; [16] How can I avoid stack overflows? 
 
;;; INTLST  - create '(0 1 2 ... n) 
(defun intlst (n / l) 
  (repeat n 
    (setq l (cons (setq n (1- n)) l)) 
  ) 
)                                        ;this looks ugly but it works 
 
 
;;;; [20] general Helper functions 
 
;;; DXF  - return the DXF group code of an (entget) list 
(defun dxf (grp ele) (cdr (assoc grp ele))) 
 
;;;; [20.1] List manipulation 
 
;;; CONSP  - a not empty list 
(defun consp (x) (and x (listp x))) 
 
;;; POSITION - returns the index of the first element in the list, 
;;; base 0, or nil if not found 
;;;   (pos x '(a b c)) -> nil, (pos b '(a b c d)) -> 1 
(defun position        (x lst / ret) 
  (if (not (zerop (setq ret (length (member x lst))))) 
    (- (length lst) ret) 
  ) 
) 
 
;;; REMOVE - Removes an item from a list (double elements allowed) 
;;;   (remove 0 '(0 1 2 3 0)) -> (1 2 3) 
(defun remove (ele lst)                        ; by Serge Volkov 
  (apply 'append (subst nil (list ele) (mapcar 'list lst))) 
) 
 
;;; REMOVE-IF - Conditional remove from flat list, 
;;; pred requires exactly 1 arg 
;;;   (remove-if 'zerop '(0 1 2 3 0)) -> (1 2 3) 
;;;   (remove-if 'numberp '(0 (0 1) "")) -> ((0 1) "") 
(defun remove-if (pred from) 
  (cond 
    ((atom from) from)                        ;nil or symbol (return that) 
    ((apply pred (list (car from))) (remove-if pred (cdr from))) 
    (t (cons (car from) (remove-if pred (cdr from)))) 
  ) 
) 
 
;;; REMOVE-IF-NOT  - keeps all elements to which the predicate applies 
;;; say: "keep if", it need not be defined recursively, also like this 
(defun remove-if-not (pred lst)                ; by Vladimir Nesterowsky 
  (apply 'append 
         (mapcar '(lambda (e) 
                    (if        (apply pred (list e)) 
                      (list e) 
                    ) 
                  ) 
                 lst 
         ) 
  ) 
) 
 
;;; ADJOIN - conses ele to list if not already in list 
;;; trick: accepts quoted lists too, such as 
;;;   (setq l '(1 2 3) (adjoin 0 'l) 
;;;    -> !l (0 1 2 3) 
(defun adjoin (ele lst / tmp) 
  (if (= (type lst) 'SYM) 
    (setq tmp lst 
          lst (eval tmp) 
    ) 
  ) 
  (setq        lst (cond ((member ele lst) lst) 
                  (t (cons ele lst)) 
            ) 
  ) 
  (if tmp 
    (set tmp lst) 
    lst 
  ) 
) 
 
;;; ROT1 - put the first element to the end, simple version 
;;;        Say "rotate by one" or "rotate left" 
(defun rot1 (lst) (append (cdr lst) (list (car lst)))) 
 
;;; BUTLAST - the list without the last element 
(defun butlast (lst) 
  (reverse (cdr (reverse lst))) 
) 
 
 
;;;; [20.2] string predicates 
 
;;; STRINGP  - string predicate: "is s a string?" 
(defun stringp (s) 
  (= (type s) 'STR) 
) 
 
;;; STRING-NOT-EMPTYP  - is str a not empty string? 
(defun string-not-emptyp (s) 
  (and (stringp s) (/= s "")) 
) 
 
;;; for more list and string manipulation code see 
;;; AI_UTILS.LSP or 
;;; [url]ftp://xarch.tu-graz.ac.at/pub/autocad/lisp/lisp.lsp[/url] and string.lsp 
;;; or at [url]http://xarch.tu-graz.ac.at/autocad/code/vnestr/strtok.lsp[/url] 
 
;;;; [20.3] symbol->string 
 
;;; SYMBOL-NAME - returns the name of a symbol as string 
;;; converts any valid lisp expression to its printed representation 
;;; (symbol-name a) -> "a",  (symbol-name '(0 1 2 a)) -> "(0 1 2 A)" 
(defun symbol-name (sym / f str tmp) 
  (setq tmp "$sym.tmp")                        ;temp. filename, should be deleted 
  (setq f (open tmp "w")) 
  (princ sym f) 
  (close f) 
  (setq        f   (open tmp "r") 
        str (read-line f) 
        f   (close f) 
  ) 
  str 
) 
 
;;;; [20.4] AutoCAD entity access 
 
;;; GETVAL  - returns the group value of an entity. 
;;; like the wellknown (dxf) function but accepts all kinds of 
;;; entity representations (ename, entget list, entsel list) 
(defun GETVAL (grp ele)                        ;"dxf value" of any ent... 
  (cond        ((= (type ele) 'ENAME)                ;ENAME 
         (cdr (assoc grp (entget ele))) 
        ) 
        ((not ele) nil)                        ;empty value 
        ((not (listp ele)) nil)                ;invalid ele 
        ((= (type (car ele)) 'ENAME)        ;entsel-list 
         (cdr (assoc grp (entget (car ele)))) 
        ) 
        (T (cdr (assoc grp ele))) 
  ) 
)                                        ;entget-list 
 
;;; Ex: (gettyp pline) => "POLYLINE" 
(defun GETTYP (ele)                        ;return type 
  (getval 0 ele) 
) 
 
;;; ENTITY  - assure ENAME 
;;; convert the entity to type ENAME (to write shorter code) 
(defun ENTITY (ele)                        ;convert to element name 
  (cond                                        ;accepts the following types: 
    ((= (type ele) 'ENAME) ele)                ; ENAME 
    ((not (listp ele)) nil)                ; error: no list 
    ((= (type (car ele)) 'ENAME) (car ele)) ; entsel-list 
    ((cdr (assoc -1 ele)))                ; entget-list or nil 
  ) 
) 
                                        ;and now just: (defun getval (grp ele) (cdr (assoc grp (entget (entity ele))))) 
 
;;; Ex: (istypep ele "TEXT") 
;;; is element a "SOLID"? 
(defun istypep (ele typ)                ;check type 
  (= (gettyp ele) typ) 
) 
 
;;; Ex: (istypep ele '("TEXT" "ATTDEF")) 
;;; is element a "TEXT" or a "ATTDEF"? 
(defun ISTYPEP (ele typ)                ;better implementation to accept lists too 
  (cond 
    ((listp typ) (member (gettyp ele) typ)) 
    ((stringp typ) (= (gettyp ele) typ));assume typ uppercase, wcmatch is slower but neater 
    (T nil) 
  ) 
) 
 
;;; Ex: (getpt (entsel))  => ( 0.1 10.0 24) 
(defun GETPT (ele)                        ;return the startpoint of any element 
  (getval 10 ele) 
)                                        ;group 10 
 
;;; Ex: (getflag pline)  => 1 if closed 
(defun GETFLAG (ele) (getval 70 ele))        ;same with the entity flag 
 
;;; FLAGSETP  - bitvalue val in flag of element set? 
;;; Ex: (flagsetp 1 pline)   => T if closed 
;;; Ex: (flagsetp 16 vertex) => T if spline control point 
(defun FLAGSETP        (val ele) 
  (bitsetp val (getflag ele)) 
) 
 
;;; Ex: (bitsetp 4 12) => T   ;bitvalue 4 (=2.Bit) in 12 (=4+8) is set 
(defun BITSETP (val flag) 
  (= (logand val flag) val) 
) 
 
;;; SSLIST - convert selection set to list. slow, but easy to write. 
;;; Note: it's also wise to use ai_ssget, because some ents could be 
;;;       on locked layers 
;;; Ex: (sslist (ai_ssget (ssget))) => list of selected unlocked ents 
;;; or  (mapcar 'entupd (sslist (ssget "X" '((8 . "TEMP"))))) 
;;;       - regens all entities on layer TEMP 
(defun SSLIST (ss / n lst) 
  (if (= 'PICKSET (type ss)) 
    (repeat (setq n (sslength ss)) 
      (setq n        (1- n) 
            lst        (cons (ssname ss n) lst) 
      ) 
    ) 
  ) 
) 
 
;;; SSMAP - apply a function to each ent in ss, in reversed order 
;;; Faster, but not so easy to understand. see [22.2] Datestamp 
;;; [renamed from SSAPPLY to SSMAP to match the stdlib name] 
;;; Ex: (ssmap 'entupd (ssget))   ; regenerate only some entities 
(defun SSMAP (fun ss / n) 
  (if (= 'PICKSET (type ss)) 
    (repeat (setq n (sslength ss)) 
      (apply fun (list (ssname ss (setq n (1- n))))) 
    ) 
  ) 
) 
;;; backwards compatibility alias: 
(setq ssapply ssmap) 
 
;;; [21.2] Plot dialog from within Lisp. Using DDE 
 
;;;  R13 code! For R12 use "autocad.dde" as the server name. Then, inside your lisp 
;;;  or script, you can do (ddecmd "_plot "). Function DDECMD will return 
;;;  nil if something wrong, or the string you passed if successful. The 
;;;  string is just like what you type under the command prompt from 
;;;  keyboard, so you need put a space or a return, which is "^13" here, 
;;;  to end the string. 
;;;  Besides, the function is very useful in the following situation: If 
;;;  within a lisp, you need call an AutoCAD transparent command like 
;;;  LAYER, normally you will use (command "_layer"), but after use this 
;;;  line, the lisp own will not be transparent. Using the function, you 
;;;  will solve this problem. 
;;; [fixed for all releases] 
(defun DDECMD (str / tmp acadver ddestr) 
  (if (not (boundp 'initiate)) 
    (cond 
      ((= 14 (setq acadver (atoi (getvar "ACADVER")))) 
       (setq ddestr "AutoCAD.R14.DDE") 
       (arxload "ddelisp") 
      ) 
      ((= 13 acadver) 
       (setq ddestr "autocad.r13.dde") 
       (xload "ddelisp") 
      ) 
      ((= 12 acadver) 
       (setq ddestr "autocad.dde") 
       (xload "ddelisp") 
      ) 
      (T (princ "DDE not supported") (exit)) 
    ) 
  ) 
  (if (not (zerop (setq tmp (initiate ddestr "system")))) 
    (progn 
      (execute tmp (strcat "[" str "]")) 
      (terminate tmp) 
      str 
    ) 
  ) 
) 
 
;;; Visual Lisp Example: 
;| 
  (setq vlax:ActiveDocument (vla-get-ActiveDocument (vlax-get-Acad-Object))) 
  (setq plt (vla-get-plot vlax:ActiveDocument))   ;=> plot object 
  (vla-PlotWindow plt pt1 pt2)                    ; define window (pts in WCS) 
  (vla-PlotPreview plt 1)                         ; 0 for partial, 1 for full 
  (vla-PlotToDevice plt "Default System Printer") ; if it exists 
|; 
 
;;;; [21.3] (entmod) and (entmake) Layers, without (command "_LAYER"...) 
 
;;; This sample routine will create a layer with any name you type: 
;;; by Reinaldo Togores <rtogores@mundivia.es> 
(defun C:MLAY () 
  (setq laynam (getstring "\nLayer name: ")) 
  (entmake 
    (list 
      '(0 . "LAYER") 
      '(5 . "28") 
      '(100 . "AcDbSymbolTableRecord") 
      '(100 . "AcDbLayerTableRecord") 
      (cons 2 laynam) 
      '(70 . 64) 
      '(62 . 7) 
      '(6 . "CONTINUOUS") 
    ) 
  ) 
) 
 
;;;; [21.6] (vports), VIEWPORT entity, pixel conversion 
 
;;; Conversion pixel to drawing units 
(defun pix2units (pix) 
  (* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))) 
) 
 
;;; Conversion drawing units to pixel 
(defun units2pix (units) 
  (* units 
     (/ (cadr (getvar "SCREENSIZE")) (getvar "VIEWSIZE")) 
  ) 
) 
 
;;;;[21.7] Select all visible objects: zoom coordinates 
 
;;; returns a list of the actual viewport corners in WCS 
(defun zoompts (/ ctr h screen ratio size size_2) 
  (setq        ctr    (xy-of (getvar "VIEWCTR")) ;3D -> 2D 
        h      (getvar "VIEWSIZE")        ;real 
        screen (getvar "SCREENSIZE")        ;2D: Pixel x,y 
        ratio  (/ (float (car screen))        ;aspect ratio 
                  (cadr screen) 
               ) 
        size   (list (* h ratio) h)        ;screensize in coords 
        size_2 (mapcar '/ size '(2.0 2.0)) 
  ) 
  (list        (mapcar '- ctr size_2) 
        (mapcar '+ ctr size_2) 
  ) 
) 
(defun xy-of (pt) (list (car pt) (cadr pt))) ;assure 2D coords 
 
;;; returns all visible entities as a selection set 
;;; one way to define this function 
(defun ssall-visible (/ l) 
  (ssget "C" (car (setq l (maptrans0-1 (zoompts)))) (cadr l)) 
) 
;;; or another 
(defun ssall-visible-1 ()                ;combine "C" and (p1 p2) to one list 
  (apply 'ssget (append '("C") (maptrans0-1 (zoompts)))) 
) 
 
;;; map some pts from WCS to UCS, easier with just one argument 
(defun maptrans0-1 (pts) 
  (mapcar '(lambda (pt) (trans pt 0 1)) pts) 
) 
 
 
;;;; [21.8] How to write XYZ data of selected objects to a file? 
 
;;; CDF - comma delimited string 
(defun cdf-point (pt) 
  (strcat (car pt) ", " (cadr pt) ", " (caddr pt)) 
) 
 
;;; SDF - space delimited, may easier be read back in to AutoCAD 
(defun sdf-point (pt) 
  (strcat (car pt) " " (cadr pt) " " (caddr pt)) 
) 
 
;;; convert this SDF format back to a point with 
(defun str->point (s) 
  (eval (read (strcat "(" s ")"))) 
) 
 
;;; Write a XYZ file of all selected objects (SDF see below) 
(defun C:XYZ (/ ss fname f) 
  (if (and (setq ss (ssget)) 
           (setq fname (getfiled "Write XYZ to file" 
                                 (strcat (getvar "DWGNAME") ".XYZ") 
                                 "XYZ" 
                                 7 
                       ) 
           ) 
           (setq f (open fname "w")) 
      ) 
    (foreach ele (sslist ss)                ; -> [20.4] 
      (foreach pt (getpts ele)                ; -> [23.1] 
        (write-line (cdf-point pt) f) 
      ) 
    ) 
  ) 
  (if f 
    (close f) 
  ) 
) 
;;; => <fname>.xyz 
;;; 0.45, 12.3, -34.0 
 
;;; For a ASC file (SDF-format) simply change all XYZ to ASC 
;;; and cdf-point to sdf-point above. 
(defun C:ASC (/ ss fname f) 
  (if (and (setq ss (ssget)) 
           (setq fname (getfiled "Write ASC to file" 
                                 (strcat (getvar "DWGNAME") ".ASC") 
                                 "ASC" 
                                 7 
                       ) 
           ) 
           (setq f (open fname "w")) 
      ) 
    (foreach ele (sslist ss)                ; -> [20.4] 
      (foreach pt (getpts ele)                ; -> [23.1] 
        (write-line (sdf-point pt) f) 
      ) 
    ) 
  ) 
  (if f 
    (close f) 
  ) 
) 
 
;;;; [22] Block Attributes 
 
;;; ATTELE  - returns entget-list of attribute attname (STRING) in element 
;;; ele or nil if not found 
(defun attele (ele attname / rslt) 
  (if (and (istypep ele "INSERT") 
           (= (getval 66 ele) 1) 
      ) 
    (progn 
      (setq ele (entnext (entity ele))) 
      (while (and ele (istypep ele "ATTRIB")) 
        (if (= (strcase (getval 2 ele)) (strcase attname)) 
          (setq        rslt (entget ele) 
                ele  nil 
          )                                ;break the loop 
          (setq ele (entnext ele)) 
        ) 
      ) 
    ) 
  ) 
  rslt 
) 
 
;;; ATTCHG  - change the attribute value of INSERT ele to new (group 1) 
(defun attchg (ele attname new / b) 
  (if (setq b (attele ele attname)) 
    (entmod (subst (cons 1 new) (getval 1 b) b)) 
  ) 
) 
 
;;; Change all DATESTAMP attributes in all inserted PLOT* blocks 
(defun C:DATESTAMP () 
  (ssmap 
    '(lambda (ele) 
       (attchg ele "DATESTAMP" (today)) 
       (entupd ele) 
     ) 
    (ssget "X" '((0 . "INSERT") (2 . "PLOT*"))) 
  ) 
) 
 
;;; TODAY  - return todays date, could be a DIESEL or this string conversion 
;;; with DIESEL it's easier to define it according your format (i.e day of week) 
(defun today (/ s) 
  (setq s (rtos (getvar "CDATE") 2))        ;gets the julian date 
  (strcat (substr s 5 2) 
          "-" 
          (substr s 7 2) 
          "-" 
          (substr s 3 2) 
  ) 
) 
 
;;; MAIN-ENTITY - some more helper funcs to get the main entity of any attribute 
;;; or vertex 
(defun main-entity (ele) 
  (setq b (entity b))                        ;force ENAME 
  (while (istypep b '("ATTRIB" "ATTDEF" "VERTEX")) 
    (setq b (entnext b)) 
  )                                        ;loop until no more sub-ents 
  (if (istypep b '("SEQEND" "ENDBLK")) 
    (getval -2 b)                        ;complex entity -> header 
    b                                        ;normal entity 
  ) 
) 
 
;;;; [23] Polylines 
 
;;; return only some assoc values in the list (for LWPOLYLINE) 
(defun GROUP-ONLY (grp lst) 
  (mapcar 'cdr 
          (remove-if-not '(lambda (pair) (= grp (car pair))) lst) 
  ) 
) 
 
;;; return the vertex list of a polyline or of any other element 
;;; Note that with edlgetent mentioned in [22.1] it's a one-liner 
(defun GETPTS (ele / pts) 
  (setq ele (entity ele))                ;force type ENAME 
  (cond 
    ((istypep ele "POLYLINE") 
     (while (istypep (setq ele (entnext ele)) "VERTEX") 
       ;; omit fit and spline points  (conservative style) 
       (if (not (or (flagsetp 1 ele) (flagsetp 8 ele))) ;bugfix! 
         (setq pts (cons (trans (getpt ele) ele 0) pts)) 
       ) 
       (reverse pts) 
     ) 
    ) 
    ;; Special case: you have to map it, assoc finds only the first. 
    ;; Fix a LWPOLYLINE bug in R14: internally stored as 2d point, 
    ;;   (entget) returns fantasy z-values. 
    ((istypep ele "LWPOLYLINE") 
     (mapcar '(lambda (pt) (trans (list (car pt) (cadr pt) 0.0) ele 0)) 
             (group-only 10 (entget ele)) 
     ) 
    ) 
    ;; insert here possible other types, such as 
    ((istypep ele '("TEXT" "CIRCLE")) (list (getpt ele))) 
    ;; more like this (serge's style) 
    (T 
     (apply 'append 
            (mapcar 
              '(lambda (n / p) 
                 (if (setq p (getval n ele)) 
                   (list p) 
                 ) 
               ) 
              '(10 11 12 13) 
            ) 
     ) 
    ) 
    ;; or like this (conservative style) 
    ;;(T (foreach n '(10 11 12 13) 
    ;;     (if (setq p (getval n ele)) (setq pts (cons p pts)))) 
    ;;  pts 
    ;;) 
  ) 
) 
 
;;; This sample converts all selected elements to polylines and 
;;;  tries to join as much as possible. 
(defun C:JOINPOLY (/ ele ss) 
  (foreach ele (sslist (setq ss (ssget))) ;better process lists 
    (if        (entget ele)                        ;not already joined 
      (cond                                ;(then it would be nil) 
        ((istypep ele '("ARC" "LINE")) 
         ;; in fact you should check Z of lines and UCS here too 
         (command "_PEDIT" ele "_Y" "_J" ss "" "") ; convert and JOIN 
        ) 
        ((and (istypep ele '("POLYLINE" "LWPOLYLINE")) ;bugfix 
              (not (flagsetp 1 ele))        ;not closed 
              (< (rem (getflag ele) 128) 8) 
         )                                ;ignore meshes and such 
         (command "_PEDIT" ele "_J" ss "" "") ;ucs check omitted 
        ) 
      ) 
    ) 
  ) 
) 
 
;;; Sets new polywidth for multiple plines 
(defun C:POLYWID (/ wid ele) 
  (initget 5) 
  (setq wid (getdist "New Polyline Width: ")) ;not negative 
  (foreach ele (sslist (ssget '((0 . "*POLYLINE")))) ;only PLINES 
    (command "_PEDIT" ele "_W" wid "") 
  ) 
) 
 
;;; Draws a POLYLINE entity from a list of points (same with SPLINE, 
;;;  or LINE), on the actual UCS, with actual OSNAP settings 
(defun draw-pline (pts) 
  (command "_PLINE") 
  (mapcar 'command pts) 
  (command "") 
) 
(defun draw-spline (pts) 
  (command "_SPLINE") 
  (mapcar 'command pts)                        ; the pts must be the fitpoints then 
  (command "" "" "") 
) 
 
;;; add up the LENGTH of all selected objects, NOISY, you can do the 
;;; same with AREAs: simply change the last line to (getvar "AREA") 
(defun C:LEN-OF        () 
  (command "_AREA" "_A" "_E")                ;add up objects (R12+13) 
  (ssmap 'command (ssget))                ;pass all elements to AutoCAD 
  (command "" "")                        ;two returns 
  (getvar "PERIMETER") 
)                                        ;this is the length 
 
;;; calculates length of a pline, quiet 
(defun POLY-LENGTH (poly / seg) 
  (apply '+                                ; the sum of all single segment lengths 
         (mapcar 
           '(lambda (seg)                ;length of one segment 
              (if (zerop (car seg))        ;is it straight? 
                (distance (cadr seg) (caddr seg)) ; line segment or 
                (abs (arclen seg)) 
              ) 
            )                                ; curved: -> [24] 
           (pline-segs poly) 
         ) 
  ) 
)                                        ;segment list (bulge p1 p2) 
 
;;; returns all group codes of the complex element 
;;; (vertices, attributes) as list, similar to (edlgetent) 
(defun CPLX-LIST (grp ele / lst) 
  (if (= 1 (getval 66 ele)) 
    (progn (setq ele (entnext (entity ele))) 
           (while (and ele (not (istypep ele "SEQEND"))) 
             (setq lst (cons (getval grp ele) lst) 
                   ele (entnext ele) 
             ) 
           ) 
           (reverse lst) 
    ) 
  ) 
) 
 
;;; PLINE-SEGS  - Creates a segment list for the polyline pname 
;;;   as a list of '(bulge p1 p2). A straight line has bulge 0.0 
;;; Compute pts in ECS of pname. Accepts LWPOLYLINE's 
(defun pline-segs (pname / pts segs) 
  (setq        segs 
         (mapcar 'list 
                 (if (istypep pname "LWPOLYLINE") 
                   (group-only 42 (entget pname)) 
                   (cplx-list 42 pname) 
                 ) 
                 (setq pts (getpts pname)) ; ->[23.1] 
                 (rot1 pts) 
         ) 
  )                                        ; ->[20.1] 
  (if (flagsetp 1 pname) 
    segs                                ;closed 
    (butlast segs) 
  ) 
)                                        ;open: without the last segment, ->[20.1] 
 
;;; Example:   (a bit optimized for brevity :) 
;;; Add up all the lengths of all selected polylines, quiet 
;;; To accept also other entities, add those to pline-segs 
(defun C:POLYLEN () 
  (apply '+ (ssmap 'poly-length (ssget '((0 . "*POLYLINE"))))) 
) 
 
;;;; [24] Circle/Arc Geometry: BULGE conversion, some trigonometry 
 
;;; SEG2CIR - converts a bulged segment (bulge pt1 pt2) of a polyline 
;;;   to a circle (ctr rad), the start- and endpoints are known 
;;;   therefore the angles too: (angle ctr pt1)(angle ctr pt2) 
;;; returns nil on a straight segment! 
(defun seg2cir (seg / bulge p1 p2 cot x y rad dummy) 
  (if (zerop (car seg))                        ;straight line => invalid circle 
    nil 
    (setq bulge        (car seg) 
          p1        (cadr seg) 
          p2        (caddr seg) 
          cot        (* 0.5 (- (/ 1.0 bulge) bulge)) 
          x        (/ (- (+ (car p1) (car p2)) (* (- (cadr p2) (cadr p1)) cot)) 
                   2.0 
                ) 
          y        (/ (+ (+ (cadr p1) (cadr p2)) (* (- (car p2) (car p1)) cot)) 
                   2.0 
                ) 
          rad        (distance (list (car p1) (cadr p1)) (list x y)) 
          dummy        (list (list x y) rad)        ; return this, I hate progn's 
    ) 
  ) 
) 
 
;;; ARC2SEG - inverse conversion: 
;;; calculates segment (bulge p1 p2) of arc 
;;;   with given circle (ctr rad), start-angle, end-angle 
;;;   (arc2seg cir (angle (car cir) p1) (angle (car cir) p2)) =>seg 
(defun arc2seg (cir ang1 ang2 / p1 p2) 
  (setq        p1 (polar (car cir) ang1 (cadr cir)) 
        p2 (polar (car cir) ang2 (cadr cir)) 
  ) 
  (list (arc2bul p1 p2 cir) p1 p2) 
) 
 
;;; ARC2BUL - calculates bulge of arc given the arc points and the 
;;;   circle (ctr rad) [fixed by Serge Pashkov] 
(defun arc2bul (p1 p2 cir / ang) 
  (setq ang (- (angle (car cir) p2) (angle (car cir) p1))) 
  (if (minusp ang) 
    (setq ang (+ (* 2.0 pi) ang)) 
  ) 
  (tan (/ ang 4.0)) 
) 
 
;;; BUL2ANG - returns inner angle of arc (bulge) 
(defun bul2ang (seg / ctr) 
  (- (angle (setq ctr (car (seg2cir seg))) (cadr seg)) 
     (angle ctr (caddr seg)) 
  ) 
) 
 
;;; ARC2ANG 
;;; calculates angle of arc given the chord distance and radius 
(defun arc2ang (chord rad) 
  (* 2.0 
     (atan 
       (/ chord 
          2.0 
          (sqrt        (- (expt rad 2) 
                   (expt (/ chord 2.0) 2) 
                ) 
          ) 
       ) 
     ) 
  ) 
) 
 
;;; ARCLEN   - length of arc   = radius*angle, 
;;; Note: +-, you'll need (abs (arclen seg)) 
(defun arclen (seg) 
  (* (cadr (seg2cir seg))                ; radius 
     4.0 
     (atan (car seg)) 
  ) 
)                                        ; angle = 4*atan(bulge) 
 
(setq *INFINITY* 1.7e308)                ; largest double 
(defun tan (z / cosz)                        ; [fixed] 
  (if (zerop (setq cosz (cos z))) 
    *INFINITY* 
    (/ (sin z) cosz) 
  ) 
) 
(defun dtr (ang) (* pi (/ ang 180.0)))        ; degree to radian 
(defun rtd (ang) (/ (* ang 180.0) pi))        ; radian to degree 
 
;;;;[26] EED Extended Entity Data: Select, Get and Store 
 
;;; here is how to get the eed list from one element for all regapps 
(defun get-eedlist-all (ele) 
  (cdadr (assoc -3 (entget (entity ele) '("*")))) 
) 
 
;;; this gets all elements of appnames rname (wildcards allowed) 
(defun ssget-app (rname) 
  (ssget "X" (list (list -3 (list rname)))) 
) 
 
;;; Check any XDATA with:   (entget (car (entsel)) '("*")) 
 
;;; GETXDATA - get all XDATA lists from an element 
;;; i.e with XDATA: 
;;; (-3  ("HUBU-1" (1000 ."ASSHATCH")(1002 ."{") 
;;;                (1070 . 1)(1002 ."}"))) 
;;; =>(("HUBU-1" (1000 ."ASSHATCH")(1002 ."{")(1070 . 1)(1002 ."}"))) 
(defun getxdata        (e apnlst) 
  (cdr (assoc -3 (entget e apnlst))) 
) 
 
;;; GETXDATA-ALL - all lists without the regapp name 
;;; => ((1000 ."ASSHATCH")(1002 ."{")(1070 . 1)(1002 ."}")) 
(defun getxdata-all (e apnlst) 
  (apply 'append (mapcar 'cdr (getxdata e apnlst))) 
) 
;;; Conversion pixel to drawing units 
(defun PIX2UNITS (pix) 
  (* pix (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))) 
) 
 
;;; Conversion drawing units to pixel 
(defun UNITS2PIX (units) 
  (* units 
     (/ (cadr (getvar "SCREENSIZE")) (getvar "VIEWSIZE")) 
  ) 
)

陌生人 · 发表于 2003-11-23 01:18:04

好贴,要是有点中文介绍,说明就更好了

jxcgn · 发表于 2003-11-27 17:17:53

什么意思??有什么用途??中文解释一下!谢了!

xxxyzxx · 发表于 2004-6-11 21:26:54

太完美了，对于组、弧线等各种方面进行了编程，唯一的遗憾兄弟们都发现了，完全英文使用起来并不是非常舒适，望楼主提供使用说明，哪怕是很简单的都好，谢谢！

cxzly · 发表于 2005-1-29 15:05:29

太好了，还是翻译成中文好用

shuaier · 发表于 2005-2-7 10:51:25

请使用国语，谢谢！

eachy · 发表于 2005-2-7 12:15:48

最初由 shuaier 发布
[B]请使用国语，谢谢！ [/B]

要是能有懂国语的编程语言岂不更好？！
直接写“打印面积”，就给你显示出来：）

li809 · 发表于 2005-2-14 20:29:14

不懂
能有中文吗

杜流浪人 · 发表于 2014-5-25 11:47:44

函数虽小解决大问题受教了

freedata · 发表于 2014-6-6 10:48:35

要是中文叫好了，现在完全看不懂

chenxc11 · 发表于 2014-6-8 05:29:43

要一个一个的看，太费时间了，有谁能不能做点工作，帮写个用法或解释

yyyyyyy234 · 发表于 2014-6-9 21:52:51

这个挺方便的

myzwsc · 发表于 2014-9-23 02:52:15

要自己找，没有使用说明

柴月二号 · 发表于 2015-11-5 13:07:09

好贴:lol:lol:lol:lol

0if0 · 发表于 2016-10-27 17:15:03

特别感谢佐治

账号		自动登录	找回密码
密码			立即注册

[转贴]：一堆 Lisp 函数

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

本帖被以下淘专辑推荐:

相关帖子