home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p047 / 4.ddi / LP / LPMC.LSP < prev    next >
Encoding:
Text File  |  1989-11-03  |  5.8 KB  |  190 lines
  1. ;*******LP\LPMC.LSP****** 11-3-89 BJ
  2. (if (null ls1) (setq ls1 "ls1"))
  3. ;----------
  4. (defun C:LPMC ( )
  5.   (if (listp ls1) (princ ls1) (mls1))
  6.   (setq wcy 1)
  7.   (while wcy
  8.     (setq wxr (getint "\n 0.!ls1/1.mls1/2.CMC/3.Ldim/4.Lcopy
  9.        <or RETURN for none>:"))
  10.     (if (= wxr nil) (setq wcy nil))
  11.     (if (= wxr 0) (print ls1))
  12.     (if (= wxr 1) (mls1))
  13.     (if (= wxr 2) (progn (p0af) (cmc)))
  14.     (if (= wxr 3) (progn (p0af) (ldim)))
  15.     (if (= wxr 4) (lcopy))
  16.   )
  17. )
  18. ;**********
  19. (defun p0af ( )
  20.   (if (null p0) (setq p0 (getpoint "enter point P0:"))
  21.     (setq new (getpoint "enter point P0 <old P0>:")))
  22.   (if new (setq p0 new))
  23.   (if (null af) (setq af (* 0.5 pi) ra 90.0))
  24.    (setq new (getangle (strcat "enter angle <" (rtos ra 2 1) ">:")))
  25.   (if new (setq af new))
  26. ; (setq af (getangle "\n enter angle <90>:"))
  27. ;   (if (null af) (setq af 90))
  28.   (setq ra (* (/ af pi) 180.0))
  29. )
  30. ;----------
  31. (defun mls1 ( )
  32.   (setq wxr 1 ls1 (list "ls1"))
  33.   (if (= mmm "M") (prompt "\n *** !mmm=M *** ")
  34.     (prompt "\n *** !mmm=MM *** "))
  35.   (while wxr
  36.     (setq ll (getreal "\n enter ll <or RETURN for none>:"))
  37.       (if (null ll) (setq wxr nil) (setq ls1 (cons ll ls1)))
  38.   )
  39.   (setq ls1 (reverse ls1))
  40. )
  41. ;----------
  42. (defun ldim ( )
  43.   (if (/= (getvar "clayer") "cc") (command "layer" "m" "cc" ""))
  44.   (setvar "dimse1" 0) (setvar "dimse2" 0)
  45.   (setq pcc (getpoint "enter point Pcc:"))
  46.   (setq n 1 pt1 p0)
  47.   (while n
  48.     (setq dl (nth n ls1))
  49.       (if (= dl nil) (setq n nil) (ldim0))
  50.   )
  51. )
  52. (defun ldim0 ( )
  53.   (setq pt2 (polar pt1 af dl))
  54.   (if (> dl 0.0) (command "DIM1" "ALI" pt1 pt2 pcc "")
  55.     (command "DIM1" "ALI" pt2 pt1 pcc ""))
  56.   (setvar "dimse1" 1)
  57.     (setq pt1 pt2)
  58.     (setq n (+ n 1))
  59. )
  60. ;----------
  61. (defun hcopy ( )
  62.   (setq ppp (ssget))
  63.   (setq wxr 1 adl 0.0 n 1)
  64.   (while wxr
  65.     (setq dl (nth n ls1))
  66.     (if (= dl nil) (setq wxr nil) (progn 
  67.       (setq adl (+ adl dl))
  68.       (command "copy" ppp "" '(0.0 0 0) (list 0 0 adl))
  69.       (setq n (1+ n)))
  70.     )
  71.   )
  72. )
  73. ;---------
  74. (defun lcopy ( )
  75.   (setq ppp (ssget))
  76.   (setq pb (getpoint "Base point:"))
  77.   (setq wxr 1 adl 0.0 n 1)
  78.   (command "copy" ppp "" pb p0)
  79.   (while wxr
  80.     (setq dl (nth n ls1))
  81.     (if (= dl nil) (setq wxr nil) (progn 
  82.       (setq adl (+ adl dl))
  83.       (command "copy" ppp "" pb (polar p0 af adl))
  84.       (setq n (1+ n)))
  85.     )
  86.   )
  87. )
  88. ;-------------------------
  89. (defun cmc ( )
  90. ; (if (null ldmbg) (setq ldmbg (getvar "elevation")))
  91. ; (setq new (getreal (strcat "LDMBG <" (rtos ldmbg 2 2) ">:")))
  92. ; (if new (setq ldmbg new))
  93. ; (setvar "elevation" ldmbg)
  94.   (setvar "thickness" 0.0)
  95.   (if (= mmm "M") (prompt "\n *** !mmm=M ***")
  96.     (prompt "\n *** !mmm=MM *** "))
  97.   (setq d1 (getreal "enter real d1 <120>:"))
  98.     (if (null d1) (setq d1 120.0))
  99.   (setq d2 (getreal "enter real d2 <120>:"))
  100.     (if (null d2) (setq d2 120.0))
  101.   (setq ql (nth 1 ls1))
  102.   (setq p1 (polar p0 af ql))
  103.   (setq wxr 1 n 2)
  104.   (while wxr
  105.     (setq mcl (nth n ls1))
  106.       (if (= mcl nil) (setq wxr nil) (progn (cmc0)
  107.          (setq ql (nth (+ n 1) ls1))
  108.          (if (/= ql nil) (setq p1 (polar p1 af (+ ql mcl))))
  109.          (setq n (+ 2 n))))
  110.   )
  111. )
  112. ;------
  113. (defun cmc0 (/ p)
  114.   (setq bmcl (* 0.5 mcl))
  115.   (setq p11 (polar p1 (+ af (* 0.5 pi)) d1))
  116.   (setq p12 (polar p11 af mcl))
  117.   (if (> (distance (getvar "viewctr") p12)
  118.     (* 0.5 (getvar "viewsize")))
  119.     (command "zoom" "c" (polar p1 af bmcl) ""))
  120.   (setq p21 (polar p1 (+ af (* -0.5 pi)) d2))
  121.   (setq p22 (polar p21 af mcl))
  122.   (if (/= (getvar "clayer") "qc") (command "layer" "m" "qc" ""))
  123.   (command "pline" p11 p21 "")
  124.   (command "pline" p12 p22 "")
  125.   (command "trim" "l" p1 "" (polar p11 af bmcl)
  126.     (polar p21 af bmcl) "")
  127.   (command "pedit" p1 "j" (polar p11 af (* -0.5 d1))
  128.     (polar p21 af (* -0.5 d2)) "" "")
  129.   (command "pedit" (polar p1 af mcl) "j" (polar p12 af (* 1.1 d1))
  130.     (polar p22 af (* 1.1 d2)) "" "")
  131.   (command "layer" "m" "mc" "")
  132.   (setq p (polar p21 (+ af (* 0.5 pi)) (* 0.5 (+ d1 d2))))
  133. ; (if (= mmm "MM")
  134. ;    (setq mcl0 (* mcl 0.001)) (setq mcl0 mcl))
  135. ; (setq mcdh (substr (getstring "Men/Cuang? <c>:") 1 1))
  136. ; (if (or (= mcdh "m") (= mcdh "M"))
  137. ;    (setq mcdh "M") (setq mcdh "C"))
  138. ; (if (= mcdh "M") (pm-m) (pm-c))
  139. ; (pm-mc0)
  140.  (pm-c)
  141. )
  142. ;------
  143. (defun pm-m ( )
  144.   (if (null mdg) (setq mdg 2700.0))
  145.   (setq new (getreal (strcat "enter MDG <" (rtos mdg 2 1) ">:")))
  146.   (if new (setq mdg new)) (setq mch mdg)
  147.   (if (< mcl0 1.1999) (cdm0))
  148.   (if (and (> mcl0 1.1999) (< mcl0 2.3999)) (csm0))
  149.   (if (> mcl0 2.3999) (c4sm0))
  150. )
  151. ;------
  152. (defun pm-c ( )
  153. ; (if (null ctg) (setq ctg 900.0))
  154. ; (setq new (getreal (strcat "enter CTG <" (rtos ctg 2 1) ">:")))
  155. ; (if new (setq ctg new))
  156. ; (if (null cdg) (setq cdg 1800.0))
  157. ; (setq new (getreal (strcat "enter CDG <" (rtos cdg 2 1) ">:")))
  158. ; (if new (setq cdg new)) (setq mch cdg)
  159.   (command "line" p11 p12 "")
  160.   (command "line" p21 p22 "")
  161.   (command "line" p (polar p af mcl) "")
  162. )
  163. ;------
  164. (defun pm-mc0 ( )
  165.   (setq mcl0s (rtos (* mcl0 10) 2 0))
  166.      (if (= (strlen mcl0s) 1) (setq mcl0s (strcat "0" mcl0s)))
  167.   (if (= mmm "MM")
  168.      (setq mch0 (* mch 0.001)) (setq mch0 mch))
  169.   (setq mch0s (rtos (* mch0 10) 2 0))
  170.      (if (= (strlen mch0s) 1) (setq mch0s (strcat "0" mch0s)))
  171.   (command "line" p (polar p af mcl) "")
  172.   (if (= mcdh "M")
  173.   (command "change" "l" "" "p" "elev" ldmbg "th" mch "lay" "3d" "")
  174.   (command "change" "l" "" "p" "elev" (+ ldmbg ctg) "th" mch "lay" "3d" ""))
  175.   (setq p (polar p21 af (* 0.5 mcl)))
  176.   (setq p (polar p (+ af (* -0.5 pi)) (* 600 tb)))
  177.   (setq mcdh0 (strcat mcdh mcl0s mch0s))
  178.   (setq mcdh (getstring (strcat "enter MCDH <" mcdh0 ">:")))
  179.     (if (= mcdh "") (setq mcdh mcdh0))
  180.   (command "text" "c" p (* 250 tb) ra mcdh)
  181.   (command "change" "l" "" "lay" "cc")
  182.   (setq mcdh0 nil)
  183. )
  184. ;**********
  185. (defun C:CLEAN2 ( )
  186.   (setq atomlist (member 'C:CLEAN2 atomlist))
  187.   'DONE2
  188. )
  189. (princ)
  190.