home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / PW.LSP < prev    next >
Encoding:
Text File  |  1992-01-30  |  20.9 KB  |  472 lines
  1. (defun pwlerr(s)
  2.   (if (/= s "Function cancelled")
  3.       (princ (strcat "\nError:" s))
  4.   )
  5.   (command "undo" "end")
  6.   (setvar "osmode" 0)
  7.   (setvar "aperture" apert)
  8.   (setvar "pickbox" pib)
  9.   (command "layer" "s" "0" "")
  10.   (setvar "cmdecho" 1)
  11.   (setq *error* oer)
  12.   (princ)
  13. )
  14.  
  15. (defun instr(st s0 s00 / l n loop x n0 l0)
  16.    (setq l (+ (- (strlen s0) st) 1) l0 0 n0 st n 1 loop t)
  17.    (while (and (<= n l) loop)
  18.       (setq x (substr s0 n0 1))
  19.       (if (eq x s00) (setq loop nil l0 n0) (setq n0 (1+ n0) n (1+ n)))
  20.    )
  21.    (eval l0)
  22. )
  23.  
  24. (defun strdv(rn / loop l x)
  25.        (setq wlist nil loop t)
  26.        (while loop
  27.           (setq l (instr 1 rn " "))
  28.           (if (= l 0) (setq wlist (cons rn wlist) loop nil)
  29.              (progn ;else
  30.              (setq x (substr rn 1 (1- l)))
  31.              (setq wlist (cons x wlist))
  32.              (setq rn (substr rn (1+ l) (- (strlen rn) l)))
  33.              (setq loop t)
  34.              )
  35.           )
  36.        )
  37.        (setq wlist (reverse wlist))
  38. )
  39.  
  40. (defun c:pw(/ oer apert pib thick elv ss lastent ssl n ssa ssb sn en ename elay w cflag sp ep sn1 en1 sn2 en2 bflag
  41.  mp sp1 ep1 sp2 ep2 sn11 sn22 sn33 sn44 osn1 osn2 trimpt ep1 ep2 mid1 mid2 ang sint1 sint2 sp3 ep3 sp4 ep4 eint1 eint2
  42.  ang1 ang2 sln eln spep cnt0 llp l n pt pt1 pt2 bkss bkssl bken bknam bklay isp iep intp n0 ip whh sx sy sz wl wh att ths
  43.  ww bn ip1 ip2 ip3 ip4 p5 p6 enchk att1 cen r r1 r2 whh0 cnt)
  44.    (setvar "cmdecho" 0)
  45.    (setq oer *error* *error* pwlerr)
  46.    (command "undo" "group")
  47.    (setq apert (getvar "aperture"))
  48.    (setq pib (getvar "pickbox"))
  49.    (setq thick (getvar "thickness"))
  50.    (setq elv (getvar "elevation"))
  51.    (setq ss (ssget) lastent (entlast))
  52.    (if ss
  53.       (progn
  54.       (setq ssl (sslength ss) n 0 ssa nil ssa (ssadd) ssb nil ssb (ssadd))
  55.       (repeat ssl
  56.          (setq sn (ssname ss n) en (entget sn))
  57.          (setq ename (cdr (assoc 0 en)) elay (cdr (assoc 8 en)))
  58.          (cond ((and (= "POLYLINE" ename) (= "PWALL" (substr elay 1 5)))
  59.             (setq w (cdr (assoc 40 en)) cflag (cdr (assoc 70 en)))
  60.             (setq sp (cdr (assoc 10 (entget (setq sn1 (entnext sn))))))
  61.             (setq ep (cdr (assoc 10 (entget (entnext sn1)))))
  62.             (setq bflag (cdr (assoc 42 (entget sn1))))
  63.             (command "pedit" sn "w" 0 "")
  64.             (command "change" sn "" "p" "t" 0 "")
  65.             (if (= bflag 0) (progn
  66.             (setq mp (polar sp (angle sp ep) (/ (distance sp ep) 2.0)))
  67.             (setq sp1 (polar mp (+ (/ pi 2) (angle sp ep)) 250))
  68.             (setq sp2 (polar mp (+ (- (/ pi 2)) (angle sp ep)) 250))
  69.             )
  70.             (progn
  71.             (setq ang (* 4 (atan bflag)))
  72.             (if (>= ang pi)
  73.             (setq ang (- (angle sp ep) (- (/ pi 2.0) (/ (- (* 2 pi) ang) 2.0))))
  74.             (setq ang (+ (angle sp ep) (- (/ pi 2.0) (/ ang 2.0))))
  75.             )
  76.             (setq sp1 (polar sp ang 250))
  77.             (setq sp2 (polar sp (+ pi ang) 250))
  78.             ))
  79.             (setq sn11 nil sn22 nil sn33 nil sn44 nil osn1 nil osn2 nil)
  80.             (command "offset" (fix (/ w 2.0)) (list sn sp) sp1 "")
  81.             (setq sn1 (entlast))
  82.             (if (= elay "PWALLW") (progn (if (= (tblsearch "layer" "pwalln") nil) (command "layer" "n" "pwalln" "")) (command "change" sn1 "" "p" "la" "pwalln" "")))
  83.             (command "explode" sn1)
  84.             (setq sn1 (entnext sn1) sn11 sn1)
  85.             (setq sn1 (entnext sn1))
  86.             (while (/= sn1 nil) (setq osn1 sn1 sn1 (entnext sn1)))
  87.             (if (/= osn1 nil) (setq sn33 osn1))
  88.             (command "offset" (fix (/ w 2.0)) (list sn sp) sp2 "")
  89.             (setq sn2 (entlast))
  90.             (command "explode" sn2)
  91.             (setq sn2 (entnext sn2) sn22 sn2)
  92.             (setq sn2 (entnext sn2))
  93.             (while (/= sn2 nil) (setq osn2 sn2 sn2 (entnext sn2)))
  94.             (if (/= osn2 nil) (setq sn44 osn2))
  95.             (if (= cflag 0) (progn
  96.                 (ssadd sn11 ssa)
  97.                 (ssadd sn22 ssa)
  98.                 (if (not (or (= sn33 nil) (= sn44 nil))) (progn
  99.                     (ssadd sn33 ssa)
  100.                     (ssadd sn44 ssa)
  101.                 ))
  102.             ))
  103.             (command "erase" sn "")
  104.             )
  105.          ((and (= ename "INSERT") (= elay "PWINDOW") (member (strcase (substr (setq bn (cdr (assoc 2 en))) 1 2)) '("MM" "CC")))
  106.          (ssadd sn ssb)
  107.         )
  108.          )
  109.          (setq n (1+ n))
  110.       )
  111.       (if ssa (progn
  112.          (princ "\nTrim processing .....")
  113.          (setvar "pickbox" 1)
  114.          (setq ssl (sslength ssa) n 0 trimpt ())
  115.          (repeat (/ ssl 2)
  116.             (setq sn1 (ssname ssa n) sn2 (ssname ssa (1+ n)))
  117.             (if (and (= (cdr (assoc 0 (entget sn1))) "LINE")
  118.                      (= (cdr (assoc 0 (entget sn2))) "LINE"))
  119.             (progn
  120.             (setq sp1 (cdr (assoc 10 (entget sn1))))
  121.             (setq ep1 (cdr (assoc 11 (entget sn1))))
  122.             (setq sp2 (cdr (assoc 10 (entget sn2))))
  123.             (setq ep2 (cdr (assoc 11 (entget sn2))))
  124.             (setq mid1 (polar sp1 (angle sp1 sp2) (/ (distance sp1 sp2) 2.0)))
  125.             (setq mid2 (polar ep1 (angle ep1 ep2) (/ (distance ep1 ep2) 2.0)))
  126.             (setq ang (angle sp1 ep1))
  127.             (setq sln (findent mid1 ang) eln (findent mid2 (+ ang pi)))
  128.             (if sln
  129.             (if (= "LINE" (cdr (assoc 0 (entget sln)))) (progn
  130.             (setq sp3 (cdr (assoc 10 (entget sln))) ep3 (cdr (assoc 11 (entget sln))))
  131.             (if (> (distance sp3 ep3) (distance sp1 sp2)) (progn
  132.             (setq sint1 (inters sp1 ep1 sp3 ep3))
  133.             (setq sint2 (inters sp2 ep2 sp3 ep3))
  134.             (if (and sint1 sint2) (progn
  135.             (newst sn1 sint1) (newst sn2 sint2)
  136.             (setq trimpt (cons (list sint1 sint2) trimpt))
  137.             )))))))
  138.             (if eln
  139.             (if (= "LINE" (cdr (assoc 0 (entget eln)))) (progn
  140.             (setq sp4 (cdr (assoc 10 (entget eln))) ep4 (cdr (assoc 11 (entget eln))))
  141.             (if (> (distance sp4 ep4) (distance ep1 ep2)) (progn
  142.             (setq eint1 (inters sp1 ep1 sp4 ep4))
  143.             (setq eint2 (inters sp2 ep2 sp4 ep4))
  144.             (if (and eint1 eint2) (progn
  145.             (newnd sn1 eint1) (newnd sn2 eint2)
  146.             (setq trimpt (cons (list eint1 eint2) trimpt))
  147.             )))))))
  148.         ) ;end progn "LINE"
  149.         (if (and (= (cdr (assoc 0 (entget sn1))) "ARC")
  150.                  (= (cdr (assoc 0 (entget sn2))) "ARC"))
  151.             (progn
  152.             (setq sp1 (car (spep sn1)) ep1 (cadr (spep sn1)))
  153.             (setq sp2 (car (spep sn2)) ep2 (cadr (spep sn2)))
  154.             (setq mid1 (polar sp1 (angle sp1 sp2) (/ (distance sp1 sp2) 2.0)))
  155.             (setq mid2 (polar ep1 (angle ep1 ep2) (/ (distance ep1 ep2) 2.0)))
  156.             (setq ang1 (angle (cdr (assoc 10 (entget sn1))) sp1))
  157.             (setq ang2 (angle (cdr (assoc 10 (entget sn1))) ep1))
  158.             (setq sln (findent mid1 (+ ang1 (/ pi 2.0))))
  159.             (setq eln (findent mid2 (- ang2 (/ pi 2.0))))
  160.             (setvar "aperture" 1)
  161.             (setvar "pickbox" 1)
  162.             (if sln (progn
  163.                (command "trim" sln "" (list sn1 (osnap sp1 "END")) (list sn2 (osnap sp2 "END")) "")
  164.                (setq sint1 (car (spep sn1)) sint2 (car (spep sn2)))
  165.                (setq trimpt (cons (list sint1 sint2) trimpt))
  166.             ))
  167.             (if eln (progn
  168.                (command "trim" eln "" (list sn1 (osnap ep1 "END")) (list sn2 (osnap ep2 "END")) "")
  169.                (setq sint1 (cadr (spep sn1)) sint2 (cadr (spep sn2)))
  170.                (setq trimpt (cons (list sint1 sint2) trimpt))
  171.             ))
  172.             )) ;end if "ARC"
  173.            ) ;endif "LINE"
  174.             (setq n (+ n 2))
  175.             )
  176.        ))
  177. (setq llp (getstring "\nContinue.."))
  178. (if (= (strcase llp) "Y") (progn
  179.       (setq cnt 0 l (length trimpt))
  180.       (repeat l
  181.         (setq n (nth cnt trimpt) mid1 (car n) mid2 (cadr n))
  182.         (setq pt (polar mid1 (angle mid1 mid2) (/ (distance mid1 mid2) 2.0)))
  183.         (setq pt1 (list (+ (car pt) 5) (+ (cadr pt) 5) (caddr pt)))
  184.         (setq pt2 (list (- (car pt) 5) (- (cadr pt) 5) (caddr pt)))
  185.         (setq bkss (ssget "c" pt1 pt2))
  186.         (if bkss (progn
  187.          (setq bkssl (sslength bkss) n0 0)
  188.          (repeat bkssl
  189.            (setq bken (entget (setq bksn (ssname bkss n0))))
  190.            (setq bknam (cdr (assoc 0 bken)) bklay (cdr (assoc 8 bken)))
  191.            (if (and (= (substr bklay 1 5) "PWALL") (member bknam '("LINE")))
  192.          (progn
  193.          (setq isp (cdr (assoc 10 bken)) iep (cdr (assoc 11 bken)))
  194.          (setq intp (inters isp iep pt (polar pt (+ (angle isp iep) 1.57079) 50) nil))
  195.          (if (and intp (equal (distance intp pt) 0 0.1))
  196.            (command "break" (list bksn pt1) "f" mid1 mid2))
  197.          ))
  198.          (setq n0 (1+ n0))
  199.          )
  200.          )) ;endif bkss
  201.         (setq cnt (1+ cnt))
  202.       )
  203.       )
  204.    )
  205. )) ;endif continue
  206.          (if ssb (progn
  207.          (setq ssl (sslength ssb) n 0)
  208.          (repeat ssl
  209.          (setq sn (ssname ssb n) en (entget sn) bn (cdr (assoc 2 en)))
  210.          (setq ip (cdr (assoc 10 en)) whh (last ip) ip (list (car ip) (cadr ip) 0))
  211.          (setq sx (abs (cdr (assoc 41 en))) att (cdr (assoc 1 (entget (setq sn1 (entnext sn))))) en1 (entget sn1))
  212.          (setq sz (cdr (assoc 43 en)) ang (cdr (assoc 50 en)))
  213.          (setq wl (* sx 100.0) wh (* sz 100.0) att (cdr (assoc 1 (entget (entnext sn)))))
  214.          (setq ths (substr att 1 (- (instr 1 att " ") 1)) ww (atof (substr att (+ (instr 1 att " ") 1))))
  215.           (setq en (subst (cons 43 (* 0.01 (/ sz sz))) (assoc 43 en) en))
  216.           (setq en (subst (cons 10 ip) (assoc 10 en) en))
  217.           (entmod en)
  218.       (cond ((and (= bn "CCC") (/= (substr att (strlen att) 1) "@"))
  219.           (setq ip1 (polar ip (- ang (/ pi 2.0)) (/ ww 2.0)))
  220.           (setq ip2 (polar ip (+ ang (/ pi 2.0)) (/ ww 2.0)))
  221.           (if (setq enchk (entfind ip1 ip2)) (progn
  222.           (setq ip3 (polar ip1 (+ ang pi) (/ wl 2.0)))
  223.           (setq ip1 (polar ip1 ang (/ wl 2.0)))
  224.           (setq ip4 (polar ip2 (+ ang pi) (/ wl 2.0)))
  225.           (setq ip2 (polar ip2 ang (/ wl 2.0)))
  226.           (setq p5 (polar ip (+ ang pi) (/ wl 2.0)))
  227.           (setq p6 (polar ip ang (/ wl 2.0)))
  228.           (setq att (strcat "C-? " (rtos wl 2 0) " " (rtos wh 2 0) " " (rtos whh 2 0) " " (rtos ww 2 0) " " ths))
  229.           (setq en1 (subst (cons 1 att) (assoc 1 en1) en1))
  230.           (entmod en1)
  231.           (command "layer" "m" "pwindow" "")
  232.           (setvar "thickness" 0)
  233.           (setvar "elevation" 0)
  234.           (command "color" "bylayer")
  235.           (command "break" (car enchk) p5 p6)
  236.           (command "line" ip3 ip4 "")
  237.           (command "break" (cadr enchk) p5 p6)
  238.           (command "line" ip1 ip2 "")
  239.           (setvar "thickness" thick)
  240.           (setvar "elevation" elv)
  241.        ))
  242.        ) ;cond1
  243.        ((and (= (substr bn 1 2) "MM") (/= (substr att (strlen att) 1) "@"))
  244.           (setq ip1 (polar ip (- ang (/ pi 2.0)) (/ ww 2.0)))
  245.           (setq ip2 (polar ip (+ ang (/ pi 2.0)) (/ ww 2.0)))
  246.           (setq ip3 (polar ip1 (+ ang pi) (/ wl 2.0)))
  247.           (setq ip1 (polar ip1 ang (/ wl 2.0)))
  248.           (setq ip4 (polar ip2 (+ ang pi) (/ wl 2.0)))
  249.           (setq ip2 (polar ip2 ang (/ wl 2.0)))
  250.           (setq att (strcat "C-? " (rtos wl 2 0) " " (rtos wh 2 0) " " (rtos whh 2 0) " " (rtos ww 2 0) " " ths))
  251.           (setq en1 (subst (cons 1 att) (assoc 1 en1) en1))
  252.           (entmod en1)
  253.           (command "layer" "m" "pwindow" "")
  254.           (setvar "thickness" 0)
  255.           (setvar "elevation" 0)
  256.           (command "color" "bylayer")
  257.           (command "line" ip3 ip4 "")
  258.           (command "line" ip1 ip2 "")
  259.        ) ;cond1
  260.        ((and (= (substr bn 1 3) "CCZ") (/= (substr att (strlen att) 1) "@"))
  261.        (setq sn2 (entnext sn1) en2 (entget sn2))
  262.        (setq att (cdr (assoc 1 en1)) att1 (cdr (assoc 1 en2)))
  263.        (setq ww (atof (substr att (+ (instr 1 att " ") 1))))
  264.        (strdv att1)
  265.        (setq sp1 (list (atof (nth 0 wlist)) (atof (nth 1 wlist)) 0))
  266.        (setq sp2 (list (atof (nth 2 wlist)) (atof (nth 3 wlist)) 0))
  267.        (setq ep2 (list (atof (nth 4 wlist)) (atof (nth 5 wlist)) 0))
  268.        (setq ep1 (list (atof (nth 6 wlist)) (atof (nth 7 wlist)) 0))
  269.        (setq ip1 (polar sp1 (angle sp1 ep1) (/ (distance sp1 ep1) 2.0)))
  270.        (setq ip2 (polar sp2 (angle sp2 ep2) (/ (distance sp2 ep2) 2.0)))
  271.       (setq att (strcat "CZ-? " (rtos (distance sp2 ep2) 2 0) " " (rtos wh 2 0) " " (rtos whh 2 0) " " (rtos ww 2 0) " " ths))
  272.       (setq en1 (subst (cons 1 att) (assoc 1 en1) en1))
  273.       (entmod en1)
  274.        (setq att1 (strcat "CZ-? " att1))
  275.        (setq en2 (subst (cons 1 att1) (assoc 1 en2) en2))
  276.        (entmod en2)
  277.        (if (setq enchk (entfind ip1 ip2)) (progn
  278.           (command "layer" "m" "pwindow" "")
  279.           (setvar "elevation" 0)
  280.           (setvar "thickness" 0)
  281.           (command "break" (car enchk) sp1 ep1)
  282.           (command "line" sp1 sp2 "")
  283.           (command "line" ep1 ep2 "")
  284.           (command "break" (cadr enchk) sp2 ep2)
  285.          ))
  286.      )
  287.      ((and (= (substr bn 1 3) "CCA") (/= (substr att (strlen att) 1) "@"))
  288.        (setq sn2 (entnext (setq sn1 (entnext sn))) en1 (entget sn1) en2 (entget sn2))
  289.        (setq att (cdr (assoc 1 en1)) att1 (cdr (assoc 1 en2)))
  290.        (setq ww (atof (substr att (+ (instr 1 att " ") 1))))
  291.        (strdv att1)
  292.      (setq sp (list (atof (nth 0 wlist)) (atof (nth 1 wlist)) 0))
  293.      (setq cen (list (atof (nth 2 wlist)) (atof (nth 3 wlist)) 0))
  294.      (setq ep (list (atof (nth 4 wlist)) (atof (nth 5 wlist)) 0))
  295.      (setq r (distance cen ip) r1 (+ r (/ ww 2.0)) r2 (- r (/ ww 2.0)))
  296.      (setq ang (angle sp ep) ang1 (angle cen sp) ang2 (angle cen ep))
  297.      (setq ip1 (polar cen (angle cen ip) r2))
  298.      (setq ip2 (polar cen (angle cen ip) r1))
  299.      (setq sp1 (polar cen (angle cen sp) r2))
  300.      (setq sp2 (polar cen (angle cen sp) r1))
  301.      (setq ep1 (polar cen (angle cen ep) r2))
  302.      (setq ep2 (polar cen (angle cen ep) r1))
  303.       (setq att (strcat "CA-? " (rtos (distance sp2 ep2) 2 0) " " (rtos wh 2 0) " " (rtos whh 2 0) " " (rtos ww 2 0) " " ths))
  304.       (setq en1 (subst (cons 1 att) (assoc 1 en1) en1))
  305.       (entmod en1)
  306.      (setq att1 (strcat "CA-? " (rtos ang1 2 2) " " (rtos ang2 2 2) " " (rtos r1 2 2) " " (rtos r2 2 2) " " (rtos whh 2 0) " " (rtos ww 2 0) " " (rtos ang 2 2)))
  307.      (setq en2 (subst (cons 1 att1) (assoc 1 en2) en2))
  308.      (entmod en2)
  309.      (if (setq enchk (arcfind ip1 ip2)) (progn
  310.        (command "break" (car enchk) sp1 ep1)
  311.        (command "break" (cadr enchk) sp2 ep2)
  312.       ))
  313.        (setvar "elevation" 0)
  314.        (setvar "thickness" 0)
  315.        (command "layer" "m" "pwindow" "")
  316.        (command "line" sp1 sp2 "")
  317.        (command "line" ep1 ep2 "")
  318.    )
  319.    ((= (substr att (strlen att) 1) "@")
  320.     (cond ((or (= bn "CCC") (= (substr bn 1 2) "MM"))
  321.       (strdv att)(setq whh0 (last wlist))
  322.       (setq att (strcat (substr bn 1 1) "-? " (rtos wl 2 0) " " (rtos wh 2 0) " " (rtos whh 2 0) " " (rtos ww 2 0) " " ths " " whh0))
  323.    (setq en1 (subst (cons 1 att) (assoc 1 en1) en1))
  324.    (entmod en1)
  325.   )
  326.   ((= (substr bn 1 3) "CCZ")
  327.    (strdv att) (setq whh0 (last wlist))
  328.     (setq sn2 (entnext sn1) en2 (entget sn2))
  329.     (setq att1 (cdr (assoc 1 en2)))
  330.    (strdv att1) (setq sp2 (list (atof (nth 2 wlist)) (atof (nth 3 wlist)) 0.0))
  331.                 (setq ep2 (list (atof (nth 4 wlist)) (atof (nth 5 wlist)) 0.0))
  332.     (setq att (strcat "CZ-? " (rtos (distance sp2 ep2) 2 0) " " (rtos wh 2 0) " " (rtos whh 2 0) " " (rtos ww 2 0) " " ths " " whh0))
  333.     (setq en1 (subst (cons 1 att) (assoc 1 en1) en1))
  334.     (entmod en1)
  335.     (setq att1 (strcat "CZ-? " att1))
  336.     (setq en2 (subst (cons 1 att1) (assoc 1 en2) en2))
  337.     (entmod en2)
  338.   )
  339.   ((= (substr bn 1 3) "CCA")
  340.    (strdv att) (setq whh0 (last wlist))
  341.    (setq sn2 (entnext sn1) en2 (entget sn2))
  342.    (setq att1 (cdr (assoc 1 en2)))
  343.    (strdv att1)
  344.    (setq sp (list (atof (nth 0 wlist)) (atof (nth 1 wlist)) 0))
  345.    (setq cen (list (atof (nth 2 wlist)) (atof (nth 3 wlist)) 0))
  346.    (setq ep (list (atof (nth 4 wlist)) (atof (nth 5 wlist)) 0))
  347.    (setq ang (angle cen ip) ang1 (angle cen sp) ang2 (angle cen ep))
  348.    (setq r (distance cen ip) r1 (+ r (/ ww 2.0)) r2 (- r (/ ww 2.0)))
  349.   (setq sp2 (polar cen ang1 r1) ep2 (polar cen ang2 r1))
  350.    (setq att (strcat "CA-? " (rtos (distance sp2 ep2) 2 0) " " (rtos wh 2 0) " " (rtos whh 2 0) " " (rtos ww 2 0) " " ths " " whh0))
  351.    (setq en1 (subst (cons 1 att) (assoc 1 en1) en1))
  352.    (entmod en1)
  353.    (setq att1 (strcat "CA-? " (rtos ang1 2 2) " " (rtos ang2 2 2) " " (rtos r1 2 2) " " (rtos r2 2 2) " " (rtos wh 2 0) " " (rtos whh 2 0) " " (rtos ww 2 0) " " (rtos (angle sp ep) 2 2)))
  354.    (setq en2 (subst (cons 1 att1) (assoc 1 en2) en2))
  355.    (entmod en2)
  356.    ))
  357.   )) ;endcond
  358.        (setq n (1+ n))
  359.        )
  360.         )
  361.          )
  362.    (command "undo" "end")
  363.    (setq *error* oer)
  364.    (setvar "cmdecho" 1)
  365.    (setvar "pickbox" pib)
  366.    (setvar "aperture" apert)
  367.    (princ)
  368. )
  369.  
  370. (defun findent(pt ang / loop l cnt en)
  371.    (setq en nil trimd 250)
  372.    (setq ss (ssget "c" (setq pt1 (polar pt ang trimd)) pt))
  373.    (if ss
  374.      (progn
  375.      (setq cnt 0 l (sslength ss) loop t)
  376.      (while (and loop (< cnt l))
  377.         (setq enchk (ssname ss cnt))
  378.         (if (and (member (cdr (assoc 0 (entget enchk))) '("LINE")) (= (substr (cdr (assoc 8 (entget enchk))) 1 5) "PWALL") (not (eq enchk sn1)) (not (eq enchk sn2)))
  379.             (progn
  380.             (setq isp (cdr (assoc 10 (entget enchk))) iep (cdr (assoc 11 (entget enchk))))
  381.             (if (and (inters isp iep sp1 ep1) (inters isp iep sp2 ep2))
  382.             (setq en enchk loop nil))
  383.         ))
  384.         (setq cnt (1+ cnt))
  385.       )
  386.       )
  387.    )
  388.    (setq en en)
  389. )
  390.  
  391. (defun newst(oldent new10)
  392.    (setq oldente (entget oldent))
  393.    (setq oldente (subst (append '(10) new10) (assoc 10 oldente) oldente))
  394.    (entmod oldente)
  395.    (setq oldent oldent)
  396. )
  397.  
  398. (defun newnd(oldent new11)
  399.    (setq oldente (entget oldent))
  400.    (setq oldente (subst (append '(11) new11) (assoc 11 oldente) oldente))
  401.    (entmod oldente)
  402.    (setq oldent oldent)
  403. )
  404.  
  405. (defun spep(sn1 / sang1 eang1 sr1 cen1 sp1 ep1)
  406.             (setq sang1 (cdr (assoc 50 (entget sn1))))
  407.             (setq eang1 (cdr (assoc 51 (entget sn1))))
  408.             (setq sr1 (cdr (assoc 40 (entget sn1))))
  409.             (setq cen1 (cdr (assoc 10 (entget sn1))))
  410.             (setq sp1 (polar cen1 sang1 sr1))
  411.             (setq ep1 (polar cen1 eang1 sr1))
  412.             (setq cen1 (list sp1 ep1))
  413. )
  414.  
  415. (defun entfind(ip1 ip2)
  416.     (setq ds 10)
  417.       (setq ip3 (list (+ (car ip1) ds) (+ (cadr ip1) ds) (caddr ip1)))
  418.       (setq ip1 (list (- (car ip1) ds) (- (cadr ip1) ds) (caddr ip1)))
  419.       (setq ip4 (list (+ (car ip2) ds) (+ (cadr ip2) ds) (caddr ip2)))
  420.       (setq ip2 (list (- (car ip2) ds) (- (cadr ip2) ds) (caddr ip2)))
  421.      (setq ss31 (ssget "c" ip3 ip1) ss42 (ssget "c" ip4 ip2))
  422.      (if (and ss31 ss42) (progn
  423.      (setq l31 (sslength ss31) l42 (sslength ss42))
  424.      (setq n0 0 lp t enchk1 nil)
  425.      (while (and lp (< n0 l31))
  426.      (setq sn31 (ssname ss31 n0) en31 (entget sn31))
  427.      (setq ename (cdr (assoc 0 en31)) elay (cdr (assoc 8 en31)))
  428.      (if (and (= "PWALL" (substr elay 1 5)) (= "LINE" ename) (> (distance (cdr (assoc 10 en31)) (cdr (assoc 11 en31))) wl))
  429.      (setq enchk1 sn31 lp nil))
  430.      (setq n0 (1+ n0))
  431.      )
  432.      (setq n0 0 lp t enchk2 nil)
  433.      (while (and lp (< n0 l42))
  434.      (setq sn42 (ssname ss42 n0) en42 (entget sn42))
  435.      (setq ename (cdr (assoc 0 en42)) elay (cdr (assoc 8 en42)))
  436.      (if (and (= "PWALL" (substr elay 1 5)) (= "LINE" ename) (> (distance (cdr (assoc 10 en42)) (cdr (assoc 11 en42))) wl) (not (eq sn31 sn42)))
  437.      (setq enchk2 sn42 lp nil))
  438.      (setq n0 (1+ n0))
  439.      )
  440.      (if (and enchk1 enchk2) (setq enchk (list enchk1 enchk2)) (setq enchk nil))
  441.    ))
  442. )
  443.  
  444. (defun arcfind(ip1 ip2)
  445.     (setq ds 10)
  446.       (setq ip3 (list (+ (car ip1) ds) (+ (cadr ip1) ds) (caddr ip1)))
  447.       (setq ip1 (list (- (car ip1) ds) (- (cadr ip1) ds) (caddr ip1)))
  448.       (setq ip4 (list (+ (car ip2) ds) (+ (cadr ip2) ds) (caddr ip2)))
  449.       (setq ip2 (list (- (car ip2) ds) (- (cadr ip2) ds) (caddr ip2)))
  450.      (setq ss31 (ssget "c" ip3 ip1) ss42 (ssget "c" ip4 ip2))
  451.      (if (and ss31 ss42) (progn
  452.      (setq l31 (sslength ss31) l42 (sslength ss42))
  453.      (setq n0 0 lp t enchk1 nil)
  454.      (while (and lp (< n0 l31))
  455.      (setq sn31 (ssname ss31 n0) en31 (entget sn31))
  456.      (setq ename (cdr (assoc 0 en31)) elay (cdr (assoc 8 en31)))
  457.      (if (and (= "PWALL" (substr elay 1 5)) (= "ARC" ename))
  458.      (setq enchk1 sn31 lp nil))
  459.      (setq n0 (1+ n0))
  460.      )
  461.      (setq n0 0 lp t enchk2 nil)
  462.      (while (and lp (< n0 l42))
  463.      (setq sn42 (ssname ss42 n0) en42 (entget sn42))
  464.      (setq ename (cdr (assoc 0 en42)) elay (cdr (assoc 8 en42)))
  465.      (if (and (= "PWALL" (substr elay 1 5)) (= "ARC" ename) (not (eq sn31 sn42)))
  466.      (setq enchk2 sn42 lp nil))
  467.      (setq n0 (1+ n0))
  468.      )
  469.      (if (and enchk1 enchk2) (setq enchk (list enchk1 enchk2)) (setq enchk nil))
  470.    ))
  471. )
  472.