home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p047 / 4.ddi / FA / 3DPOM.LSP < prev    next >
Encoding:
Text File  |  1988-12-28  |  5.2 KB  |  174 lines
  1. ;******FA\3DPOM.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. (defun e0t0 ( )
  8.     (setq se (getvar "elevation"))
  9.     (setq st (getvar "thickness"))
  10.   (setvar "elevation" 0)
  11.   (setvar "thickness" 0)
  12. )
  13. (defun ests ( )
  14.   (setvar "elevation" se)
  15.   (setvar "thickness" st)
  16. )
  17. ;******
  18. (defun C:PLP0 ( )
  19.   (e0t0)
  20.   (setq plp0 (getpoint "\n enter point plp0<viewctr>:"))
  21.     (if (null plp0) (setq plp0 (getvar "viewctr")))
  22.   (if (/= (getvar "clayer") "plp0") (command "layer" "m" "plp0" ""))
  23.   (if (/= (getvar "cecolor") "1") (command "color" "1"))
  24.   (setq vl (* (getvar "viewsize") 0.5))
  25.   (command "pline" (setq p1 (polar plp0 (* -0.5 pi) vl))
  26.     (setq p1 (polar p1 (* 0.5 pi) (* vl 2))) plp0
  27.     (setq p1 (polar plp0 pi (* 1.267666 vl)))
  28.     (setq p1 (polar p1 0.0 (* vl 2.535333))) "")
  29. )
  30. (defun rplp0 ( )
  31.   (command "osnap" "int")
  32.   (setq ppp (entsel "enter point to pline:"))
  33.   (command "osnap" "")
  34.   (setq plp0 (cadr ppp))
  35.   (setq lhh0 (cadr plp0) bhb0 (car plp0))
  36.   (setq lbb0 (caddr (assoc 10 (entget (entnext (car ppp))))))
  37.   (setq lbl0 (cadr (assoc 10 (entget (entnext
  38.     (entnext (entnext (entnext (entnext)))))))))
  39. )
  40. ;******3D-PO******
  41. (defun C:3dPOLH ( )
  42.   (if (/= (getvar "clayer") "po") (command "layer" "m" "polh" ""))
  43.   (setq pq1 (getpoint "enter point PQ1:"))
  44.   (setq pq2 (getpoint "enter point PQ2:"))
  45.   (setq 2dpto2d 2dptolh)
  46.   (setq 3dpto2d 3dptolh)
  47.   (3dpo0)
  48. )
  49. (defun C:3dPOBH ( )
  50.   (if (/= (getvar "clayer") "po") (command "layer" "m" "pobh" ""))
  51.   (setq 2dpto2d 2dptobh)
  52.   (setq 3dpto2d 3dptobh)
  53.   (setq pq1 (getpoint "enter point PQ1:"))
  54.   (setq pq2 (getpoint "enter point PQ2:"))
  55.   (setq pq2 (list (car pq1) (cadr pq2)))
  56.   (command "pline" (polar pq1 pi (* 1000 tb)) "w" (* 50 tb) "" pq1 
  57.      (polar pq1 (* 0.5 pi) (* 2000 tb)) "")
  58.   (command "pline" (polar pq2 (* -0.5 pi)  (* 2000 tb)) pq2 
  59.      (polar pq2 pi (* 1000 tb)) "")
  60.   (3dpo0)
  61. )
  62. (defun 3dpo0 ( )
  63.   (setq ppp (ssget))
  64.   (e0t0)
  65.   (setq wcy 0 n (sslength ppp))
  66.     (while (< wcy n)
  67.       (setq s (cdr (assoc 0 (setq e (entget (ssname ppp wcy))))))
  68.       (command "color" (cdr (assoc 62 e)))
  69.         (if (= "LINE" s) (lpo))
  70.         (if (= "POINT" s) (pto2d))
  71.         (if (= "INSERT" s) (bto2d))
  72.         (if (= "3DLINE" s) (3dlto2d))
  73.         (if (= "3DFACE" s) (3dfto2d))
  74.       (setq wcy (1+ wcy))
  75.       (prompt "Working...")
  76.     )
  77.   (ests)
  78. )
  79. ;------------
  80. (defun 2dptolh (2dp)
  81.   (setq 2dp (list (car 2dp) (+ h01 lhh0)))
  82. )
  83. (defun 2dptobh (2dp)
  84.   (setq 2dp (list (+ (- (cadr 2dp) lbb0) bhb0) (+ h01 lhh0)))
  85. )
  86. (defun 3dptolh (3dp)
  87.   (setq 2dp (list (car 3dp) (+ (caddr 3dp) lhh0)))
  88. )
  89. (defun 3dptobh (3dp)
  90.   (setq 2dp (list (+ bhb0 (- (cadr 3dp) lbb0))
  91.       (+ (caddr 3dp) lhh0)))
  92. )
  93. (defun 3dptolb (3dp)
  94.   (setq 2dp (list (- (+ (car 3dp) bhb0) lbl0) (cadr 3dp)))
  95. )
  96. ;------------
  97. (defun pto2d ( )
  98.   (setq 2dp1 (cdr (assoc 10 e)))
  99.   (setq h01 (cdr (assoc 38 e)))
  100.     (if (= h01 nil) (setq h01 0.0))
  101.   (setq h11 (cdr (assoc 39 e)))
  102.     (if (= h11 nil) (setq h11 0.0))
  103.   (setq p1 (2dpto2d 2dp1))
  104.   (if (= h11 0) (command "point" p1)
  105.     (command "line" p1 (polar p1 1.570796 h11) "")
  106.   )
  107. )
  108. ;------------
  109. (defun bto2d ( )
  110.   (setq 2dp1 (cdr (assoc 10 e)))
  111.   (setq h01 (cdr (assoc 38 e)))
  112.     (if (= h01 nil) (setq h01 0.0))
  113.   (setq p1 (2dpto2d 2dp1))
  114.   (setq bname (cdr (assoc 2 e)))
  115.   (setq bname (strcat "fa/2dl" (substr bname 3)))
  116.   (setq xc (cdr (assoc 41 e)))
  117.   (setq zc (cdr (assoc 43 e)))
  118.   (setq af (cdr (assoc 50 e)))
  119.     (if (null af) (setq af 0.0))
  120.   (if (= 2dpto2d 2dptolh)
  121.     (setq xc (* xc (cos af))) (setq xc (* xc (sin af))))
  122.   (command "insert" bname p1 xc zc 0.0)
  123. )
  124. ;------------
  125. (defun lpo ( )
  126.   (setq 2dp1 (cdr (assoc 10 e)))
  127.   (setq 2dp2 (cdr (assoc 11 e)))
  128.   (setq h01 (cdr (assoc 38 e)))
  129.     (if (= h01 nil) (setq h01 0.0))
  130.   (setq h11 (cdr (assoc 39 e)))
  131.     (if (= h11 nil) (setq h11 0.0))
  132.   (setq pint (inters pq1 pq2 2dp1 2dp2))
  133.   (if pint (progn
  134.       (setq p1 (2dpto2d pint))
  135.       (if (= h11 0) (command "point" p1)
  136.         (command "line" p1 (polar p1 (* 0.5 pi) h11) ""))))
  137. )
  138. ;------------
  139. (defun 3dlto2d ( )
  140.   (setq 3dp1 (cdr (assoc 10 e)))
  141.   (setq 3dp2 (cdr (assoc 11 e)))
  142.   (setq p1 (3dpto2d 3dp1))
  143.   (setq p2 (3dpto2d 3dp2))
  144.   (command "line" p1 p2 "")
  145. )
  146. (defun 3dfto2d ( )
  147.   (setq 3dp1 (cdr (assoc 10 e)))
  148.   (setq 3dp2 (cdr (assoc 11 e)))
  149.   (setq 3dp3 (cdr (assoc 12 e)))
  150.   (setq 3dp4 (cdr (assoc 13 e)))
  151.   (setq p1 (3dpto2d 3dp1))
  152.   (setq p2 (3dpto2d 3dp2))
  153.   (setq p3 (3dpto2d 3dp3))
  154.   (setq p4 (3dpto2d 3dp4))
  155.   (if (= sol "on") (command "solid" p1 p2 p4 p3 "")
  156.     (command "line" p1 p2 p3 p4 "c"))
  157. )
  158. (defun 3df-lb ( )
  159.   (setq px (car 3dp1) py (cadr 3dp1))
  160.   (setq p1 (list (+ px nl0) (+ py nb0)))
  161.   (setq px (car 3dp2) py (cadr 3dp2))
  162.   (setq p2 (list (+ px nl0) (+ py nb0)))
  163.   (setq px (car 3dp3) py (cadr 3dp3))
  164.   (setq p3 (list (+ px nl0) (+ py nb0)))
  165.   (setq px (car 3dp4) py (cadr 3dp4))
  166.   (setq p4 (list (+ px nl0) (+ py nb0)))
  167.   (3dfdwg)
  168. )
  169. ;----------
  170. (defun C:CLEAN2 ( )
  171.   (setq atomlist (member 'C:CLEAN2 atomlist))
  172.   'DONE2
  173. )
  174.