home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / PWALL.LSP < prev    next >
Encoding:
Text File  |  1991-11-26  |  8.1 KB  |  199 lines
  1. (defun c:pwall(/)
  2.    (command "undo" "group")
  3.    (setvar "cmdecho" 0)
  4.    (setq ss (ssget) lastent (entlast))
  5.    (if ss
  6.       (progn
  7.       (setq ssl (sslength ss) n 0 ssa nil ssa (ssadd))
  8.       (repeat ssl
  9.          (setq sn (ssname ss n) en (entget sn))
  10.          (setq ename (cdr (assoc 0 en)) elay (cdr (assoc 8 en)))
  11.          (if (and (= "POLYLINE" ename) (= "PWALL" elay))
  12.             (progn
  13.             (setq w (cdr (assoc 40 en)) cflag (cdr (assoc 70 en)))
  14.             (setq sp (cdr (assoc 10 (entget (setq sn1 (entnext sn))))))
  15.             (setq ep (cdr (assoc 10 (entget (entnext sn1)))))
  16.             (setq bflag (cdr (assoc 42 (entget sn1))))
  17.             (command "pedit" sn "w" 0 "")
  18.             (if (= bflag 0) (progn
  19.             (setq mp (polar sp (angle sp ep) (/ (distance sp ep) 2.0)))
  20.             (setq sp1 (polar mp (+ (/ pi 2) (angle sp ep)) 250))
  21.             (setq sp2 (polar mp (+ (- (/ pi 2)) (angle sp ep)) 250))
  22.             )
  23.             (progn
  24.             (setq ang (* 4 (atan bflag)))
  25.             (if (>= ang pi)
  26.             (setq ang (- (angle sp ep) (- (/ pi 2.0) (/ (- (* 2 pi) ang) 2.0))))
  27.             (setq ang (+ (angle sp ep) (- (/ pi 2.0) (/ ang 2.0))))
  28.             )
  29.             (setq sp1 (polar sp ang 250))
  30.             (setq sp2 (polar sp (+ pi ang) 250))
  31.             ))
  32.             (setq sn11 nil sn22 nil sn33 nil sn44 nil osn1 nil osn2 nil)
  33.             (command "offset" (/ w 2) (list sn sp) sp1 "")
  34.             (setq sn1 (entlast))
  35.             (command "explode" sn1)
  36.             (setq sn1 (entnext sn1) sn11 sn1)
  37.             (setq sn1 (entnext sn1))
  38.             (while (/= sn1 nil) (setq osn1 sn1 sn1 (entnext sn1)))
  39.             (if (/= osn1 nil) (setq sn33 osn1))
  40.             (command "offset" (/ w 2) (list sn sp) sp2 "")
  41.             (setq sn2 (entlast))
  42.             (command "explode" sn2)
  43.             (setq sn2 (entnext sn2) sn22 sn2)
  44.             (setq sn2 (entnext sn2))
  45.             (while (/= sn2 nil) (setq osn2 sn2 sn2 (entnext sn2)))
  46.             (if (/= osn2 nil) (setq sn44 osn2))
  47.             (if (= cflag 0) (progn
  48.                 (ssadd sn11 ssa)
  49.                 (ssadd sn22 ssa)
  50.                 (if (not (or (= sn33 nil) (= sn44 nil))) (progn
  51.                     (ssadd sn33 ssa)
  52.                     (ssadd sn44 ssa)
  53.                 ))
  54.             ))
  55.             (command "erase" sn "")
  56.             )
  57.          )
  58.          (setq n (1+ n))
  59.       )
  60.       (if ssa (progn
  61.          (princ "\nTrim processing .....")
  62.          (setq ssl (sslength ssa) n 0 trimpt ())
  63.          (repeat (/ ssl 2)
  64.             (setq sn1 (ssname ssa n) sn2 (ssname ssa (1+ n)))
  65.             (if (and (= (cdr (assoc 0 (entget sn1))) "LINE")
  66.                      (= (cdr (assoc 0 (entget sn2))) "LINE"))
  67.             (progn
  68.             (setq sp1 (cdr (assoc 10 (entget sn1))))
  69.             (setq ep1 (cdr (assoc 11 (entget sn1))))
  70.             (setq sp2 (cdr (assoc 10 (entget sn2))))
  71.             (setq ep2 (cdr (assoc 11 (entget sn2))))
  72.             (setq mid1 (polar sp1 (angle sp1 sp2) (/ (distance sp1 sp2) 2.0)))
  73.             (setq mid2 (polar ep1 (angle ep1 ep2) (/ (distance ep1 ep2) 2.0)))
  74.             (setq ang (angle sp1 ep1))
  75.             (setq sln (findent mid1 ang) eln (findent mid2 (+ ang pi)))
  76.             (if sln
  77.             (if (= "LINE" (cdr (assoc 0 (entget sln)))) (progn
  78.             (setq sp3 (cdr (assoc 10 (entget sln))) ep3 (cdr (assoc 11 (entget sln))))
  79.             (if (> (distance sp3 ep3) (distance sp1 sp2)) (progn
  80.             (setq sint1 (inters sp1 ep1 sp3 ep3 nil))
  81.             (setq sint2 (inters sp2 ep2 sp3 ep3 nil))
  82.             (if (and sint1 sint2) (progn
  83.             (newst sn1 sint1) (newst sn2 sint2)
  84.             (setq trimpt (cons (list sint1 sint2) trimpt))
  85.             )))))))
  86.             (if eln
  87.             (if (= "LINE" (cdr (assoc 0 (entget eln)))) (progn
  88.             (setq sp4 (cdr (assoc 10 (entget eln))) ep4 (cdr (assoc 11 (entget eln))))
  89.             (if (> (distance sp4 ep4) (distance ep1 ep2)) (progn
  90.             (setq eint1 (inters sp1 ep1 sp4 ep4 nil))
  91.             (setq eint2 (inters sp2 ep2 sp4 ep4 nil))
  92.             (if (and eint1 eint2) (progn
  93.             (newnd sn1 eint1) (newnd sn2 eint2)
  94.             (setq trimpt (cons (list eint1 eint2) trimpt))
  95.             )))))))
  96.         ) ;end progn "LINE"
  97.         (if (and (= (cdr (assoc 0 (entget sn1))) "ARC")
  98.                  (= (cdr (assoc 0 (entget sn2))) "ARC"))
  99.             (progn
  100.             (setq sp1 (car (spep sn1)) ep1 (cadr (spep sn1)))
  101.             (setq sp2 (car (spep sn2)) ep2 (cadr (spep sn2)))
  102.             (setq mid1 (polar sp1 (angle sp1 sp2) (/ (distance sp1 sp2) 2.0)))
  103.             (setq mid2 (polar ep1 (angle ep1 ep2) (/ (distance ep1 ep2) 2.0)))
  104.             (setq ang1 (angle (cdr (assoc 10 (entget sn1))) sp1))
  105.             (setq ang2 (angle (cdr (assoc 10 (entget sn1))) ep1))
  106.             (setq sln (findent mid1 (+ ang1 (/ pi 2.0))))
  107.             (setq eln (findent mid2 (- ang2 (/ pi 2.0))))
  108.             (setq apt (getvar "aperture"))
  109.             (setq pib (getvar "pickbox"))
  110.             (setvar "aperture" 1)
  111.             (setvar "pickbox" 1)
  112.             (if sln (progn
  113.                (command "trim" sln "" (list sn1 (osnap sp1 "END")) (list sn2 (osnap sp2 "END")) "")
  114.                (setq sint1 (car (spep sn1)) sint2 (car (spep sn2)))
  115.                (setq trimpt (cons (list sint1 sint2) trimpt))
  116.             ))
  117.             (if eln (progn
  118.                (command "trim" eln "" (list sn1 (osnap ep1 "END")) (list sn2 (osnap ep2 "END")) "")
  119.                (setq sint1 (cadr (spep sn1)) sint2 (cadr (spep sn2)))
  120.                (setq trimpt (cons (list sint1 sint2) trimpt))
  121.             ))
  122.             (setvar "aperture" apt)
  123.             (setvar "pickbox" pib)
  124.             )) ;end if "ARC"
  125.            ) ;endif "LINE"
  126.             (setq n (+ n 2))
  127.             )
  128.        ))
  129. (setq llp (getstring "\nContinue.."))
  130. (if (= (strcase llp) "Y") (progn
  131.       (setq cnt 0 l (length trimpt))
  132.       (repeat l
  133.         (setq n (nth cnt trimpt) mid1 (car n) mid2 (cadr n))
  134.         (setq pt (polar mid1 (angle mid1 mid2) (/ (distance mid1 mid2) 2.0)))
  135.         (setq pt1 (list (+ (car pt) 5) (+ (cadr pt) 5) (caddr pt)))
  136.         (setq pt2 (list (- (car pt) 5) (- (cadr pt) 5) (caddr pt)))
  137.         (setq bkss (ssget "c" pt1 pt2))
  138.         (if bkss (progn
  139.          (setq bkssl (sslength bkss) n0 0)
  140.          (repeat bkssl
  141.            (setq bken (entget (setq bksn (ssname bkss n0))))
  142.            (setq bknam (cdr (assoc 0 bken)) bklay (cdr (assoc 8 bken)))
  143.            (if (and (= bklay "PWALL") (member bknam '("LINE" "ARC")))
  144.            (command "break" (list bksn pt1) "f" mid1 mid2))
  145.          (setq n0 (1+ n0))
  146.          )
  147.          )) ;endif bkss
  148.         (setq cnt (1+ cnt))
  149.       )
  150.       )
  151.    )
  152. )) ;endif continue
  153.    (command "undo" "end")
  154.    (setvar "cmdecho" 1)
  155.    (princ)
  156. )
  157.  
  158. (defun findent(pt ang / loop l cnt en)
  159.    (setq en nil trimd 200)
  160.    (setq ss (ssget "c" pt (setq pt1 (polar pt ang trimd))))
  161.    (if ss
  162.      (progn
  163.      (setq cnt 0 l (sslength ss) loop t)
  164.      (while (and loop (< cnt l))
  165.         (setq enchk (ssname ss cnt))
  166.         (if (and (member (cdr (assoc 0 (entget enchk))) '("LINE" "ARC")) (= (cdr (assoc 8 (entget enchk))) "PWALL") (not (eq enchk sn1)) (not (eq enchk sn2)))
  167.             (setq en enchk loop nil)
  168.         )
  169.         (setq cnt (1+ cnt))
  170.       )
  171.       )
  172.    )
  173.    (setq en en)
  174. )
  175.  
  176. (defun newst(oldent new10)
  177.    (setq oldente (entget oldent))
  178.    (setq oldente (subst (append '(10) new10) (assoc 10 oldente) oldente))
  179.    (entmod oldente)
  180.    (setq oldent oldent)
  181. )
  182.  
  183. (defun newnd(oldent new11)
  184.    (setq oldente (entget oldent))
  185.    (setq oldente (subst (append '(11) new11) (assoc 11 oldente) oldente))
  186.    (entmod oldente)
  187.    (setq oldent oldent)
  188. )
  189.  
  190. (defun spep(sn1 / sang1 eang1 sr1 cen1 sp1 ep1)
  191.             (setq sang1 (cdr (assoc 50 (entget sn1))))
  192.             (setq eang1 (cdr (assoc 51 (entget sn1))))
  193.             (setq sr1 (cdr (assoc 40 (entget sn1))))
  194.             (setq cen1 (cdr (assoc 10 (entget sn1))))
  195.             (setq sp1 (polar cen1 sang1 sr1))
  196.             (setq ep1 (polar cen1 eang1 sr1))
  197.             (setq cen1 (list sp1 ep1))
  198. )
  199.