home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p047 / 4.ddi / FA / 3DPLP.LSP < prev    next >
Encoding:
Text File  |  1989-10-16  |  8.4 KB  |  298 lines
  1. ;******FA\3DPLP.LSP******
  2. (if (null sol) (setq sol "off"))
  3. (if (null lbl0) (setq lbl0 0.0))
  4. (if (null lbb0) (setq lbb0 0.0))
  5. (if (null lhh0) (setq lhh0 (cadr (getvar "viewctr"))))
  6. (if (null bhb0) (setq bhb0 (car (getvar "viewctr"))))
  7. (if (null arcn) (setq arcn 12))
  8. ;------------
  9. (defun e0t0 ( )
  10.     (setq se (getvar "elevation"))
  11.     (setq st (getvar "thickness"))
  12.   (setvar "elevation" 0)
  13.   (setvar "thickness" 0)
  14. )
  15. (defun ests ( )
  16.   (setvar "elevation" se)
  17.   (setvar "thickness" st)
  18. )
  19. ;******
  20. (defun C:PLP0 ( )
  21.   (e0t0)
  22.   (setq plp0 (getpoint "\n enter point plp0<viewctr>:"))
  23.     (if (null plp0) (setq plp0 (getvar "viewctr")))
  24.   (if (/= (getvar "clayer") "plp0") (command "layer" "m" "plp0"
  25.     "c" "1" "" ""))
  26.   (setq vl (* (getvar "viewsize") 0.5))
  27.   (setq bhb0 (car plp0) lhh0 (cadr plp0))
  28.   (setq lbl0 (- bhb0 (* vl 1.267666)))
  29.   (setq lbb0 (- lhh0 vl))
  30.   (command "pline" (list bhb0 lbb0) (list bhb0 (+ lhh0 vl))
  31.     plp0 (list lbl0 lhh0) (list (+ lbl0 (* vl 2.535333)) lhh0) "")
  32. ; (command "pline" (setq p1 (polar plp0 (* -0.5 pi) vl))
  33. ;   (setq p1 (polar p1 (* 0.5 pi) (* vl 2))) plp0
  34. ;   (setq p1 (polar plp0 pi (* 1.267666 vl)))
  35. ;   (setq p1 (polar p1 0.0 (* vl 2.535333))) "")
  36. )
  37. (defun rplp0 ( )
  38.   (setvar "osmode" 32)
  39.   (setq ppp (entsel "enter point to pline:"))
  40.   (setvar "osmode" 0)
  41.   (setq plp0 (cadr ppp))
  42.   (setq lhh0 (cadr plp0) bhb0 (car plp0))
  43.   (setq lbb0 (caddr (assoc 10 (entget (entnext (car ppp))))))
  44.   (setq lbl0 (cadr (assoc 10 (entget (entnext
  45.     (entnext (entnext (entnext (entnext)))))))))
  46. )
  47. ;******LM-3D******
  48. (defun C:LH-3D ( )
  49.   (setq 2dpto3d lhpto3d)
  50.   (lm-3d)
  51. )
  52. (defun C:BH-3D ( )
  53.   (setq 2dpto3d bhpto3d)
  54.   (lm-3d)
  55. )
  56. ;--------------------
  57. (defun lm-3d ( )
  58.   (setq ppp (ssget))
  59.   (setq cp (getpoint "enter point cp:"))
  60.   (setq cpx (car cp) cpy (cadr cp))
  61.   (if (/= (getvar "clayer") "3d") (command "layer" "m" "3d" ""))
  62.   (setq wcy 0 n (sslength ppp))
  63.     (while (< wcy n)
  64.       (setq ss (ssname ppp wcy))
  65.       (setq s (cdr (assoc 0 (setq e (entget ss)))))
  66.       (command "color" (cdr (assoc 62 e)))
  67.       (prompt "Working...")
  68.         (if (= "LINE" s) (lto3d))
  69.         (if (= "INSERT" s) (bto3d))
  70.         (if (= "POLYLINE" s) (plto3d))
  71.         (if (= "SOLID" s) (sto3d))
  72.         (if (or (= "CIRCLE" s) (= "ARC" s)) (arcto3d))
  73.       (setq wcy (1+ wcy))
  74.     )
  75. )
  76. (defun lhpto3d (2dp)
  77.   (setq 2dpx (car 2dp) 2dpy (cadr 2dp))
  78.   (setq 3dp (list 2dpx cpy (- 2dpy lhh0)))
  79. )
  80. (defun bhpto3d (2dp)
  81.   (setq 2dpx (car 2dp) 2dpy (cadr 2dp))
  82.   (setq 3dp (list cpx (+ lbb0 (- 2dpx bhb0)) (- 2dpy lhh0)))
  83. )
  84. ;---------------
  85. (defun lto3d ( )
  86.   (setq 2dp1 (cdr (assoc 10 e)))
  87.   (setq 3dp1 (2dpto3d 2dp1))
  88.   (setq 2dp2 (cdr (assoc 11 e)))
  89.   (setq 3dp2 (2dpto3d 2dp2))
  90.   (command "3dline" 3dp1 3dp2 "")
  91. )
  92. ;------------
  93. (defun bto3d ( )
  94.   (setq 2dp1 (cdr (assoc 10 e)))
  95.   (setq 3dp1 (2dpto3d 2dp1))
  96.   (setq bname (cdr (assoc 2 e)))
  97.   (setq bname (strcat "fa/3d" (substr bname 4)))
  98.   (setq xc (cdr (assoc 41 e)))
  99.   (setq zc (cdr (assoc 42 e)))
  100.   (command "insert" bname 3dp1 xc zc 0.0)
  101. )
  102. ;---------------
  103. (defun plto3d ( )
  104.   (setq ss1 (entnext ss))
  105.   (setq ss2 (entget ss1))
  106.   (setq 2dplist (list (cdr (assoc 10 ss2))))
  107.   (setq wxr 1)
  108.   (while wxr
  109.     (setq ss1 (entnext ss1))
  110.     (setq ss2 (entget ss1))
  111.     (if (= (cdr (assoc 0 ss2)) "SEQEND") (setq wxr nil)
  112.         (progn
  113.          (setq 2dp1 (cdr (assoc 10 ss2)))
  114.          (setq 2dplist (cons 2dp1 2dplist))))
  115.   )
  116.   (setq 3dplist (mapcar '(lambda (x) (2dpto3d x)) 2dplist))
  117. ; (setq 3dplist (append 3dplist '("c")))
  118. ; (mapcar '(lambda (x) (command "3dline" x)) 3dplist)
  119.   (drawll02 3dplist)
  120.   (prompt "ok!")
  121. )
  122. (defun drawll02 (ll02)
  123.   (setq wwxr 0 drawn (length ll02))
  124.   (setq 3dp0 (nth 0 ll02) 3dp1 3dp0)
  125.   (while (< wwxr drawn)
  126.     (setq 3dp2 (nth wwxr ll02))
  127.     (command "3dline" 3dp1 3dp2 "")
  128.     (setq 3dp1 3dp2)
  129.     (setq wwxr (1+ wwxr))
  130.   )
  131.   (command "3dline" 3dp2 3dp0 "")
  132. )
  133. ;---------------
  134. (defun arcto3d (/ c1 r a1 a2 aa n an)
  135.   (setq an (/ pi arcn 0.5))
  136.   (setq c0 (cdr (assoc 10 e)))
  137.   (setq r (cdr (assoc 40 e)))
  138.   (setq a1 (cdr (assoc 50 e)))
  139.      (if (= a1 nil) (setq a1 0.0))
  140.   (setq a2 (cdr (assoc 51 e)))
  141.      (if (= a2 nil) (setq a2 (* pi 2)))
  142.   (setq aa (- a2 a1))
  143.      (if (< aa 0.0) (setq aa (+ aa pi pi)))
  144.   (setq n (fix (/ (abs aa) an)))
  145.      (if (= n 0) (setq n 1))
  146.   (setq an (/ aa n))
  147.   (setq 2dplist (list (polar c0 a1 r)))
  148.   (setq k 1)
  149.   (while (<= k n)
  150.      (setq aa (+ (* an k) a1))
  151.      (setq 2dp1 (polar c0 aa r))
  152.      (setq 2dplist (cons 2dp1 2dplist))
  153.      (setq k (1+ k))
  154.   )
  155.   (setq 3dplist (mapcar '(lambda (x) (2dpto3d x)) 2dplist))
  156. ; (setq 3dplist (append 3dplist '("c")))
  157. ; (mapcar '(lambda (x) (command "3dline" x)) 3dplist)
  158.   (drawll02 3dplist)
  159.   (prompt "ok!")
  160. )
  161. ;--------------
  162. (defun sto3d ( )
  163.   (setq 2dp1 (cdr (assoc 10 e)))
  164.   (setq 3dp1 (2dpto3d 2dp1))
  165.   (setq 2dp2 (cdr (assoc 11 e)))
  166.   (setq 3dp2 (2dpto3d 2dp2))
  167.   (setq 2dp3 (cdr (assoc 12 e)))
  168.   (setq 3dp3 (2dpto3d 2dp3))
  169.   (setq 2dp4 (cdr (assoc 13 e)))
  170.   (setq 3dp4 (2dpto3d 2dp4))
  171.   (command "3dface" 3dp1 3dp2 3dp4 3dp3 "")
  172. )
  173. ;******3D-LM******
  174. (defun C:3D-LH ( )
  175.   (setq 2dpto2d 2dptolh)
  176.   (setq 3dpto2d 3dptolh)
  177.   (3d-2d0)
  178. )
  179. (defun C:3D-BH ( )
  180.   (setq 2dpto2d 2dptobh)
  181.   (setq 3dpto2d 3dptobh)
  182.   (3d-2d0)
  183. )
  184. (defun 3d-2d0 ( )
  185.   (if (/= (getvar "clayer") "lm") (command "layer" "m" "lm" ""))
  186.   (setq ppp (ssget))
  187.   (e0t0)
  188.   (setq wcy 0 n (sslength ppp))
  189.     (while (< wcy n)
  190.       (setq s (cdr (assoc 0 (setq e (entget (ssname ppp wcy))))))
  191.       (command "color" (cdr (assoc 62 e)))
  192.         (if (= "LINE" s) (lto2d))
  193.         (if (= "POINT" s) (pto2d))
  194.         (if (= "INSERT" s) (bto2d))
  195.         (if (= "3DLINE" s) (3dlto2d))
  196.         (if (= "3DFACE" s) (3dfto2d))
  197.       (setq wcy (1+ wcy))
  198.       (prompt "Working...")
  199.     )
  200.   (ests)
  201. )
  202. ;------------
  203. (defun 2dptolh (2dp)
  204.   (setq 2dp (list (car 2dp) (+ h01 lhh0)))
  205. )
  206. (defun 2dptobh (2dp)
  207.   (setq 2dp (list (+ (- (cadr 2dp) lbb0) bhb0) (+ h01 lhh0)))
  208. )
  209. (defun 3dptolh (3dp)
  210.   (setq 2dp (list (car 3dp) (+ (caddr 3dp) lhh0)))
  211. )
  212. (defun 3dptobh (3dp)
  213.   (setq 2dp (list (+ bhb0 (- (cadr 3dp) lbb0))
  214.       (+ (caddr 3dp) lhh0)))
  215. )
  216. (defun 3dptolb (3dp)
  217.   (setq 2dp (list (- (+ (car 3dp) bhb0) lbl0) (cadr 3dp)))
  218. )
  219. ;------------
  220. (defun pto2d ( )
  221.   (setq 2dp1 (cdr (assoc 10 e)))
  222.   (setq h01 (cdr (assoc 38 e)))
  223.     (if (= h01 nil) (setq h01 0.0))
  224.   (setq h11 (cdr (assoc 39 e)))
  225.     (if (= h11 nil) (setq h11 0.0))
  226.   (setq p1 (2dpto2d 2dp1))
  227.   (if (= h11 0) (command "point" p1)
  228.     (command "line" p1 (polar p1 1.570796 h11) "")
  229.   )
  230. )
  231. ;------------
  232. (defun bto2d ( )
  233.   (setq 2dp1 (cdr (assoc 10 e)))
  234.   (setq h01 (cdr (assoc 38 e)))
  235.     (if (= h01 nil) (setq h01 0.0))
  236.   (setq p1 (2dpto2d 2dp1))
  237.   (setq bname (cdr (assoc 2 e)))
  238.   (setq bname (strcat "fa/2dl" (substr bname 3)))
  239.   (setq xc (cdr (assoc 41 e)))
  240.   (setq zc (cdr (assoc 43 e)))
  241.   (setq af (cdr (assoc 50 e)))
  242.     (if (null af) (setq af 0.0))
  243.   (if (= 2dpto2d 2dptolh)
  244.     (setq xc (* xc (cos af))) (setq xc (* xc (sin af))))
  245.   (command "insert" bname p1 xc zc 0.0)
  246. )
  247. ;------------
  248. (defun lto2d ( )
  249.   (setq 2dp1 (cdr (assoc 10 e)))
  250.   (setq 2dp2 (cdr (assoc 11 e)))
  251.   (setq h01 (cdr (assoc 38 e)))
  252.     (if (= h01 nil) (setq h01 0.0))
  253.   (setq h11 (cdr (assoc 39 e)))
  254.     (if (= h11 nil) (setq h11 0.0))
  255.   (setq p1 (2dpto2d 2dp1))
  256.   (setq p2 (2dpto2d 2dp2))
  257.   (if (= h11 0) (command "line" p1 p2 "")
  258.       (command "line" p1 p2 (polar p2 (* 0.5 pi) h11)
  259.         (polar p1 (* 0.5 pi) h11) "c")
  260.   )
  261. )
  262. ;------------
  263. (defun 3dlto2d ( )
  264.   (setq 3dp1 (cdr (assoc 10 e)))
  265.   (setq 3dp2 (cdr (assoc 11 e)))
  266.   (setq p1 (3dpto2d 3dp1))
  267.   (setq p2 (3dpto2d 3dp2))
  268.   (command "line" p1 p2 "")
  269. )
  270. (defun 3dfto2d ( )
  271.   (setq 3dp1 (cdr (assoc 10 e)))
  272.   (setq 3dp2 (cdr (assoc 11 e)))
  273.   (setq 3dp3 (cdr (assoc 12 e)))
  274.   (setq 3dp4 (cdr (assoc 13 e)))
  275.   (setq p1 (3dpto2d 3dp1))
  276.   (setq p2 (3dpto2d 3dp2))
  277.   (setq p3 (3dpto2d 3dp3))
  278.   (setq p4 (3dpto2d 3dp4))
  279.   (if (= sol "on") (command "solid" p1 p2 p4 p3 "")
  280.     (command "line" p1 p2 p3 p4 "c"))
  281. )
  282. (defun 3df-lb ( )
  283.   (setq px (car 3dp1) py (cadr 3dp1))
  284.   (setq p1 (list (+ px nl0) (+ py nb0)))
  285.   (setq px (car 3dp2) py (cadr 3dp2))
  286.   (setq p2 (list (+ px nl0) (+ py nb0)))
  287.   (setq px (car 3dp3) py (cadr 3dp3))
  288.   (setq p3 (list (+ px nl0) (+ py nb0)))
  289.   (setq px (car 3dp4) py (cadr 3dp4))
  290.   (setq p4 (list (+ px nl0) (+ py nb0)))
  291.   (3dfdwg)
  292. )
  293. ;----------
  294. (defun C:CLEAN2 ( )
  295.   (setq atomlist (member 'C:CLEAN2 atomlist))
  296.   'DONE2
  297. )
  298.