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