home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p047 / 4.ddi / PM / MMCB.LSP < prev    next >
Encoding:
Text File  |  1990-08-08  |  7.4 KB  |  280 lines
  1. ;****** PM\MMCB.LSP ****** 11-4-89 BJ
  2. (if (null tb) (setq tb0 100 tb 1.0 mmm "MM"))
  3. ;----------------------
  4. (defun C:MMCB (/ wcy)
  5.   (rgcf1)
  6.   (wgcf1)
  7.   (setq wcy 1)
  8.   (rll11 nlll)
  9.   (while wcy
  10.   (setq mode (getint 
  11.     "\n 1.Rsj/2.Wcsj-s/3.Wcsj-r/4.Cll01/5.Dll12/6.A-MCB
  12.       <or RETURN for none>:"))
  13.     (if (= mode nil) (setq wcy nil))
  14.     (if (= mode 1) (rll12))
  15.     (if (= mode 2) (progn (c-mcb) (rll11 nlll)))
  16.     (if (= mode 3) (progn (c-mcb) (rll11 nlll)))
  17.     (if (= mode 4) (progn (cll01) (rll11 nlll)))
  18.     (if (= mode 5) (progn (dll12) (rll11 nlll)))
  19. ;   (if (= mode 6) (progn (a-mcb) (rll11 nlll)))
  20.     (if (= mode 6) (progn (snil) (a-mcb) (wgcf2) (setq wcy nil)))
  21.   )
  22.   (if (/= mode 6) (wgcf2))
  23. ; (wgcf2)
  24. )
  25. ;------------
  26. (defun snil ( )
  27. (setq rgcf1 nil wgcf1 nil rll12 nil cll01 nil dll12 nil)
  28. (setq c-mcb nil c-mcb01 nil c-mcb02 nil mes nil addc nil addc01 nil)
  29. )
  30. ;------------
  31. (defun rll12 ( )
  32.   (setq ll01 (getstring (strcat 
  33.     "\n " ll11 " enter ll01:")))
  34.     (if (= ll01 "") (setq ll01 "tb"))
  35.   (setq ll12 (assoc ll01 nlll))
  36.   (print ll12)
  37.   (setq ll02 (cdr ll12))
  38. )
  39. (defun cll01 ( )
  40.   (setq ll01 (getstring (strcat 
  41.     "\n " ll11 " enter old ll01:")))
  42.   (setq ll12 (assoc ll01 nlll))
  43.   (setq nll01 (getstring "enter new ll01:"))
  44.     (if (/= nll01 "") (setq nll12 (subst nll01 ll01 ll12)) 
  45.        (setq nll12 ll12))
  46.   (print nll12)
  47.   (setq nlll (subst nll12 ll12 nlll))
  48. )
  49. (defun dll12 ( / olll)
  50.   (setq ll01 (getstring (strcat 
  51.     "\n " ll11 " enter ll01 for del:")))
  52.   (setq wxr (length nlll) k 0 olll nlll nlll nil)
  53.   (while (< k wxr)
  54.     (setq ll12 (nth k olll))
  55.       (if (/= (car ll12) ll01)
  56.         (setq nlll (cons ll12 nlll)))
  57.     (setq k (1+ k))
  58.   )
  59.   (setq nlll (reverse nlll))
  60. )
  61. (defun wll120 ( )
  62.   (setq nll12 (cons ll01 nll02))
  63.   (setq ll12 (assoc ll01 nlll))
  64.   (if (= ll12 nil) (setq nlll (cons nll12 nlll))
  65.      (setq nlll (subst nll12 ll12 nlll))
  66.   )
  67. )
  68. ;------
  69. (defun rgcf1 ( )
  70.   (setq fn1 (strcat (getvar "dwgname") ".gcl"))
  71.   (setq f1 (open fn1 "r"))
  72.      (if (= f1 nil) (setq lll (list (list "tb0" tb0 tb mmm)))
  73.        (progn (setq lll (read (read-line f1))) (close f1))
  74.      )
  75.   (setq nlll lll)
  76. )
  77. (defun wgcf1 ( )
  78.   (setq fn1 (strcat (getvar "dwgname") ".gcb"))
  79.   (setq f1 (open fn1 "w"))
  80.   (prin1 lll f1)
  81.   (close f1)
  82.   (setq lll nil)
  83. )
  84. (defun wgcf2 ( )
  85.   (setq fn2 (strcat (getvar "dwgname") ".gcl"))
  86.   (setq f2 (open fn2 "w"))
  87.   (prin1 nlll f2)
  88.   (close f2)
  89. )
  90. (defun rll11 (nlll)
  91.   (setq wxr (length nlll) k 0 ll11 "*")
  92.   (while (< k wxr)
  93.     (setq ll01 (car (nth k nlll)))
  94.     (setq ll11 (strcat ll01 "/" ll11))
  95.     (setq k (1+ k))
  96.   )
  97. )
  98. ;------------
  99. ;------------
  100. (defun c-mcb ( )
  101.   (prompt (strcat "\n old SJ:" ll11))
  102.   (setq ll01 (strcase (substr (getstring "\n PTC/BZC? <p>") 1 1)))
  103.     (if (= ll01 "B")
  104.       (progn (setq n (getint "\n Number n <3>:"))
  105.         (if (null n) (setq n 3))
  106.         (setq ll01 (strcat "BCMC" (rtos n 2 0))))
  107.       (progn (setq cs (getint "\n enter ?CMC <1>"))
  108.         (if (null cs) (setq cs 1))
  109.         (setq ll01 (strcat (rtos cs 2 0) "CMC")))
  110.     )
  111.   (if (= mode 2) (c-mcb01))
  112.   (if (= mode 3) (c-mcb02))
  113.   (setq sss (reverse sss))
  114.   (addc sss)
  115.   (wll120)
  116.   (print nll12)
  117. )
  118. (defun c-mcb01 ( )
  119.   (setq ppp (ssget))
  120.   (prompt "Working...")
  121.   (setq wcy 0 n (sslength ppp) sss nil)
  122.   (while (< wcy n)
  123.     (setq ss (ssname ppp wcy))
  124.     (setq e (entget ss))
  125.     (setq s (cdr (assoc 8 e)))
  126.     (if (= (substr s 1 2) "MC") (mes))
  127.     (setq wcy (1+ wcy))
  128.   )
  129. )
  130. (defun mes ( )
  131.   (setq s (cdr (assoc 0 e)))
  132.   (if (= s "TEXT")
  133.     (setq sss (cons (list (cdr (assoc 1 e)) 1) sss)))
  134.   (if (= s "INSERT") (progn (setq new nil)
  135.     (setq es (cdr (assoc 2 e)))
  136.     (setq ss1 (entnext (entnext ss)))
  137.     (if ss1 (setq new (cdr (assoc 1 (entget (entnext ss1))))))
  138.     (if new (setq es new))
  139.     (setq sss (cons (list es 1) sss))))
  140. )
  141. (defun c-mcb02 ( )
  142.   (setq wxr 1 sss nil)
  143.   (while wxr
  144.     (setq mcdh (getstring "\n enter MCDH <or RETRUN for none>:"))
  145.     (if (= mcdh "") (setq wxr nil) (progn
  146.       (setq n (getint "Number of every floor <1>:"))
  147.       (if (null n) (setq n 1))
  148.       (setq sss (cons (list mcdh n) sss))
  149.       (print sss))
  150.     )
  151.   )
  152. )
  153. (defun addc (sss)
  154.   (setq wcy 0 n (length sss) nll02 nil)
  155.   (while (< wcy n)
  156.     (setq ss1 (nth wcy sss))
  157.     (if (/= ss1 nil) (progn
  158.       (setq ss101 (car ss1) ss102 (cadr ss1))
  159.       (addc01)
  160.       (setq nll02 (cons (list ss101 ss102) nll02))))
  161.     (setq wcy (1+ wcy))
  162.   )
  163.   (setq nll02 (reverse nll02))
  164. )
  165. (defun addc01 ( )
  166.   (setq wxr (1+ wcy))
  167.   (while (< wxr n)
  168.     (setq ss2 (nth wxr sss))
  169.     (if (and (/= ss2 nil) (= (car ss1) (car ss2)))
  170.       (setq ss102 (1+ ss102)))
  171.     (setq wxr (1+ wxr))
  172.   )
  173.   (if (= (substr ll01 1 1) "B")
  174.     (setq ss102 (* ss102 (atoi (substr ll01 5)))))
  175.   (setq sss (subst nil ss1 sss))
  176. )
  177. ;------------
  178. (defun a-mcb ( )
  179. ; (setq atomlist (member 'C:CLEAN2 atomlist))
  180.   (setq wxr 1 ccc nil sss nil)
  181.   (while wxr
  182.     (prompt (strcat "\n old SJ:" ll11))
  183.     (if ccc (print (reverse ccc)))
  184. (setq ss1 (getstring "\n Select ?CMC? (or RETURN for continuor>:"))
  185.     (if (= ss1 "") (setq wxr nil)
  186.       (progn
  187.         (setq ss1 (strcase ss1))
  188.         (setq ss1 (assoc ss1 nlll))
  189.         (if ss1 (progn (setq sss (cons ss1 sss))
  190.              (setq ccc (cons (car ss1) ccc)))
  191.            (prompt " 0 found, "))
  192.       )
  193.     )
  194.   )
  195.   (prompt "Working...")
  196.   (setq ccc (reverse ccc))
  197.   (setq sss (reverse sss))
  198.   (if ccc (progn (mnsss sss)
  199.     (setq nsss (cdr nsss))
  200.     (adda nsss)
  201.     (savsss ccc sss)))
  202. )
  203. (defun mnsss (sss)
  204.   (setq cccn (length ccc))
  205.   (setq cck 0 nsss '("MCBA"))
  206.   (while (< cck cccn)
  207.     (setq ssk (assoc (nth cck ccc) sss))
  208.     (if ssk (mnssk))
  209.     (setq nsss (append (cdr nssk) nsss))
  210.     (setq cck (1+ cck))
  211.   )
  212.   (setq nsss (reverse nsss))
  213. )
  214. (defun mnssk ( / k)
  215.   (setq ssk01 (car ssk) ssk02 (cdr ssk))
  216.   (setq k 0 ssk02n (length ssk02) nssk02 nil)
  217.   (while (< k ssk02n)
  218.     (setq ss (nth k ssk02))
  219.     (if ss (mnss))
  220.     (setq nssk02 (cons nss nssk02))
  221.     (setq k (1+ k))
  222.   )
  223.   (setq nssk (cons ssk01 (reverse nssk02)))
  224. )
  225. (defun mnss ( / k)
  226.   (setq ss01 (car ss) ss02 (cadr ss))
  227.   (setq nss02 nil k 0)
  228.   (while (< k cccn)
  229.     (if (= k cck) (setq nss02 (cons ss02 nss02))
  230.        (setq nss02 (cons 0 nss02)))
  231.     (setq k (1+ k))
  232.   )
  233.   (setq nss (cons ss01 (reverse nss02)))
  234. )
  235. (defun adda (nsss)
  236.   (setq wcy 0 n (length nsss) sss nil)
  237.   (while (< wcy n)
  238.     (setq ss1 (nth wcy nsss))
  239.     (if ss1 (progn
  240.       (setq ss101 (car ss1) ss102 (cdr ss1))
  241.       (adda01) (adda02)
  242.       (setq sss (cons (cons ss101 ss102) sss))))
  243.     (setq wcy (1+ wcy))
  244.   )
  245.   (setq sss (reverse sss))
  246. )
  247. (defun adda01 ( )
  248.   (setq wxr (1+ wcy))
  249.   (while (< wxr n)
  250.     (setq ss2 (nth wxr nsss))
  251.     (if (and (/= ss2 nil) (= ss101 (car ss2)))
  252.       (progn (setq ss202 (cdr ss2))
  253.         (setq ss102 (mapcar '+ ss102 ss202))
  254.         (setq nsss (subst nil ss1 nsss))
  255.         (setq nsss (subst nil ss2 nsss))))
  256.     (setq wxr (1+ wxr))
  257.   )
  258. )
  259. (defun adda02 ( / k n)
  260.   (setq aa 0 k 0 n (length ss102))
  261.   (while (< k n)
  262.     (setq aa (+ (nth k ss102) aa))
  263.     (setq k (1+ k))
  264.   )
  265.   (setq ss102 (append ss102 (list aa)))
  266. )
  267. ;---------
  268. (defun savsss (ccc sss)
  269.   (setq ll01 "A-MCB")
  270.   (setq nll02 (cons ccc sss))
  271.   (wll120)
  272.   (print nll12)
  273. )
  274. ;----------------------
  275. ;(defun C:CLEAN2 ( )
  276. ; (setq atomlist (member 'C:CLEAN2 atomlist))
  277. ; (princ)
  278. ;)
  279. (princ)
  280.