lwpoly23dpoly - 3dpoly2lwpoly.lsp

admin

1. ; transptucs & transptwcs by M.R. (Marko Ribar, d.i.a.)
2. ; arguments :
3. ; pt - point to be transformed from WCS to imaginary UCS with transptucs and from imaginary UCS to WCS with transptwcs
4. ; pt1 - origin of imaginary UCS
5. ; pt2 - point to define X axis of imaginary UCS (vector pt1-pt2 represents X axis)
6. ; pt3 - point to define Y axis of imaginary UCS (vector pt1-pt3 represents Y axis)
7. ; important note : angle between X and Y axises of imaginary UCS must always be 90 degree for correct transformation calculation
9. ;; Unit Vector - M.R.
10. ;; Args: v - vector in R^n
12. (defun unit ( v )
13.   (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
14. )
16. ;; Matrix x Vector - Vladimir Nesterovsky
17. ;; Args: m - nxn matrix, v - vector in R^n
19. (defun mxv ( m v )
20.   (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
21. )
23. ;; Vector Cross Product - Lee Mac
24. ;; Args: u,v - vectors in R^3
26. (defun v^v ( u v )
27.   (list
28.     (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
29.     (- (* (car  v) (caddr u)) (* (car  u) (caddr v)))
30.     (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
31.   )
32. )
34. (defun transptucs ( pt p1 p2 p3 / ux uy uz )
35.   (setq uz (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))))
36.   (setq ux (unit (mapcar '- p2 p1)))
37.   (setq uy (unit (mapcar '- p3 p1)))
38.   
39.   (mxv (list ux uy uz) (mapcar '- pt p1))
40. )
42. (defun transptwcs ( pt pt1 pt2 pt3 / pt1n pt2n pt3n )
43.   (setq pt1n (transptucs '(0.0 0.0 0.0) pt1 pt2 pt3))
44.   (setq pt2n (transptucs '(1.0 0.0 0.0) pt1 pt2 pt3))
45.   (setq pt3n (transptucs '(0.0 1.0 0.0) pt1 pt2 pt3))
46.   (transptucs pt pt1n pt2n pt3n)
47. )
49. (defun entmakelwpoly3dpts ( ptlst 70dxfflag / ux uy uz uptlst )
50.   (setq uz (unit (v^v (mapcar '- (cadr ptlst) (car ptlst)) (mapcar '- (caddr ptlst) (car ptlst)))))
51.   (if (equal uz '(0.0 0.0 1.0) 1e-8) (setq ux '(1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
52.   (if (equal uz '(0.0 0.0 -1.0) 1e-8) (setq ux '(-1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
53.   (if (not (or (equal uz '(0.0 0.0 1.0) 1e-8) (equal uz '(0.0 0.0 -1.0) 1e-8))) (setq ux (unit (v^v '(0.0 0.0 1.0) uz))))
54.   (if (not uy) (setq uy (unit (v^v uz ux))))
55.   (setq uptlst (mapcar '(lambda ( p ) (transptucs p '(0.0 0.0 0.0) ux uy)) ptlst))
56.   (entmake
57.     (append
58.       (list
59.         '(0 . "LWPOLYLINE")
60.         '(100 . "AcDbEntity")
61.         '(100 . "AcDbPolyline")
62.         (cons 90 (length uptlst))
63.         (cons 70 70dxfflag)
64.         '(62 . 3)
65.         (cons 38 (caddar uptlst))
66.       )
67.       (mapcar '(lambda ( x ) (list 10 (car x) (cadr x))) uptlst)
68.       (list (cons 210 uz))
69.     )
70.   )
71.   (princ)
72. )
74. (defun c:lwpoly23dpoly ( / lwpol lwdxf lwptl lwel ux uy uz ptlst )
75.   (setq lwpol (car (entsel "\nPick lwpolyline to convert to 3dpolyline")))
76.   (if (and lwpol (= (cdr (assoc 0 (setq lwdxf (entget lwpol)))) "LWPOLYLINE"))
77.     (progn
78.       (setq lwptl (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) lwdxf))
79.       (setq lwptl (mapcar '(lambda ( x ) (cdr x)) lwptl))
80.       (setq lwel (cdr (assoc 38 lwdxf)))
81.       (setq lwptl (mapcar '(lambda ( x ) (list (car x) (cadr x) lwel)) lwptl))
82.       (setq uz (cdr (assoc 210 lwdxf)))
83.       (if (equal uz '(0.0 0.0 1.0) 1e-8) (setq ux '(1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
84.       (if (equal uz '(0.0 0.0 -1.0) 1e-8) (setq ux '(-1.0 0.0 0.0) uy '(0.0 1.0 0.0)))
85.       (if (not (or (equal uz '(0.0 0.0 1.0) 1e-8) (equal uz '(0.0 0.0 -1.0) 1e-8))) (setq ux (unit (v^v '(0.0 0.0 1.0) uz))))
86.       (if (not uy) (setq uy (unit (v^v uz ux))))
87.       (setq ptlst (mapcar '(lambda ( p ) (transptwcs p '(0.0 0.0 0.0) ux uy)) lwptl))
88.       (entmake
89.         (list
90.           '(0 . "POLYLINE")
91.           '(100 . "AcDbEntity")
92.           '(100 . "AcDb3dPolyline")
93.           '(66 . 1)
94.           '(62 . 1)
95.           '(10 0.0 0.0 0.0)
96.           (cons 70 (+ 8 (cdr (assoc 70 lwdxf))))
97.           '(210 0.0 0.0 1.0)
98.         )
99.       )
100.       (foreach pt ptlst
101.         (entmake
102.           (list
103.             '(0 . "VERTEX")
104.             '(100 . "AcDbEntity")
105.             '(100 . "AcDbVertex")
106.             '(100 . "AcDb3dPolylineVertex")
107.             (cons 10 pt)
108.             '(70 . 32)
109.           )
110.         )
111.       )
112.       (entmake
113.         (list
114.           '(0 . "SEQEND")
115.           '(100 . "AcDbEntity")
116.         )
117.       )
118.     )
119.     (prompt "\nNo lwpolyline picked")
120.   )
121.   (princ)
122. )
124. (defun c:3dpoly2lwpoly ( / pol vert pt ptlst )
125.   (setq pol (car (entsel "\nPick 3dpolyline to convert to lwpolyline")))
126.   (if (and pol (= (cdr (assoc 100 (cdr (member (assoc 100 (entget pol)) (entget pol))))) "AcDb3dPolyline"))
127.     (progn
128.       (setq vert (entnext pol))
129.       (while (= (cdr (assoc 0 (entget vert))) "VERTEX")
130.         (setq pt (cdr (assoc 10 (entget vert))))
131.         (setq ptlst (cons pt ptlst))
132.         (setq vert (entnext vert))
133.       )
134.       (setq ptlst (reverse ptlst))
135.       (entmakelwpoly3dpts ptlst (- (cdr (assoc 70 (entget pol))) 8))
136.     )
137.     (prompt "\nNo 3dpolyline picked")
138.   )
139.   (princ)
140. )
142. (prompt "\nDefined functions are c:lwpoly23dpoly and c:3dpoly2lwpoly")
143. (princ)

复制代码

admin

1. (defun 采用3dlwpolyline  (l col d70 / vl v1 v2 norm z)
2.   (setq vl (mapcar (function (lambda (a b) (mapcar (function -) a b))) (cdr l) l))
3.   (setq        v1 (car vl)
4.         vl (cdr vl))
5.   (while (and vl (not norm))
6.     (setq v2 (cadr vl)
7.           vl (cdr vl))
8.     (if        (equal (setq norm (v^v v1 v2)) '(0 0 0) 1e-6)
9.       (setq norm nil)))
10.   (if norm
11.     (progn
12.       (setq z (caddr (trans (car l) 0 norm))
13.             l (mapcar
14.                 (function (lambda (a)
15.                             (reverse (cdr (reverse (trans a 0 norm))))))
16.                 l))
17.       (entmakex
18.         (append
19.           (list
20.             (cons 0 "LWPOLYLINE")
21.             (cons 100 "AcDbEntity")
22.             (cons 100 "AcDbPolyline")
23.             (cons 90 (length l))
24.             (cons 70 d70)
25.             (cons 38 z))
26.           (mapcar (function (lambda (a) (cons 10 a))) l)
27.           (list        (cons 62 col)
28.                 (cons 210 norm))
29.           )))
30.     )
31.   )

复制代码

admin

1. (defun c:2dpe ()
2.   (setq sset (ssget '((-4 . "<OR")(0 . "POINT")
3.                       (0 . "LWPOLYLINE")(-4 . "OR>"))))
4.   (if sset
5.     (progn
6.       (setq itm 0 num (sslength sset))
7.       (setq fn (getfiled "save to file &#935;,&#933;" "" "txt" 1))
8.       (if (/= fn nil)
9.         (progn
10.           (setq fh (open fn "w"))
11.           (while (< itm num)
12.             (setq hnd (ssname sset itm))
13.             (setq ent (entget hnd))
14.             (setq obj (cdr (assoc 0 ent)))
15.             (cond
16.               ((= obj "POINT")
17.                 (setq pnt (cdr (assoc 10 ent)))
18.                 (setq pnt (trans pnt 0 1));;**CAB
19.                 (princ (strcat (rtos (car pnt) 2 3) ","
20.                                (rtos (cadr pnt) 2 3)) fh)
21.                 (princ "\n" fh)
22.               )
23.               ((= obj "LWPOLYLINE")
24.                 (if (= (cdr (assoc 38 ent)) nil)
25.                   (setq elv 0.0)
26.                   (setq elv (cdr (assoc 38 ent)))
27.                 )
28.                 (foreach rec ent
29.                   (if (= (car rec) 10)
30.                     (progn
31.                       (setq pnt (cdr rec))
32.                       (setq pnt (trans pnt 0 1));;**CAB
33.                       (princ (strcat (rtos (car pnt) 2 3) ","
34.                                      (rtos (cadr pnt) 2 3)) fh)
35.                       (princ "\n" fh)
36.                     )
37.                   )
38.                 )
39.               )
40.               (t nil)
41.             )
42.             (setq itm (1+ itm))
43.           )
44.           (close fh)
45.         )
46.       )
47.     )
48.   )
49.   (princ)
50. )
51. (princ)

复制代码