home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / SELV.LSP < prev    next >
Encoding:
Text File  |  1992-01-31  |  10.0 KB  |  220 lines
  1. (vmon)
  2.  
  3. (defun selerr(s)
  4.    (if (/= s "Function cancelled")
  5.        (princ (strcat "\nError:" s))
  6.    )
  7.    (command)
  8.    (command "layer" "s" olay "")
  9.    (setvar "cmdecho" 1)
  10.    (setq *error* oer)
  11.    (princ)
  12. )
  13.  
  14. (setq fn 1 eh 3300.0)
  15.  
  16. (defun C:SELV(/ oer wlist insp inspx inspy ss ssl n n0 n1 spl epl wl intl sn en ename sp ep bn ang en1 en2 en3 en4 sn1 sn2 sn3 sn4 wh nwlength wlength wwidth wthick rang splx eplx ll dx xmin xmax sp1 ep1 sp2 xx yy x olay apl arss
  17. tpl tspl terhgt intp cenp rad cenp1 rad1 edge apll ax axmin axmax tintl txmax txmin n2 flag file pas kword ssa entl)
  18.    (setvar "CMDECHO" 0)
  19.    (setq olay (getvar "CLAYER"))
  20.    (setq oer *error* *error* selerr)
  21.    (if (/= (+ fh78 fh65 fh72 fh85 fh70) 370) (tst))
  22.    (princ "\n╩Σ╚δ▓π╕▀ <")
  23.    (princ (fix eh))
  24.    (setq eh (if (setq x (getreal ">: ")) x eh))
  25.    (princ "\n╩Σ╚δ▓π╩² <")
  26.    (princ fn)
  27.    (setq fn (if (setq x (getint ">: ")) x fn))
  28.    (initget "File")
  29.    (setq insp (getpoint "\n─╧┴ó├µ┤µ┼╠F/<▓σ╚δ╡π>:"))
  30.    (if (= insp "File") (progn
  31.    (setq flag "File")
  32.    (setq pas t)
  33.    (while pas
  34.    (setq file (getstring "\n─╧┴ó├µ╬─╝■├√:"))
  35.    (if (findfile (strcat file ".DWG")) (progn
  36.        (initget "Yes No")
  37.        (setq kword (getkword "\n╕├╬─╝■╥╤╛¡┤µ╘┌,╓╪╨┤┬≡(Y/N)"))
  38.        (if (= kword "Yes") (setq pas nil))
  39.    ) (setq pas nil))
  40.    )
  41.    (setq insp (getpoint "\n▓σ╚δ╡π:")) ))
  42.    (setq inspx (car insp) inspy (cadr insp))
  43.    (setq ss (ssget))
  44.    (if ss (progn
  45.        (setq ssl (sslength ss) n 0 spl nil epl nil apl nil wl nil arss nil arss (ssadd) tpl nil)
  46.        (repeat ssl
  47.           (setq sn (ssname ss n) en (entget sn))
  48.           (setq ename (cdr (assoc 0 en)))
  49.           (cond ((and (eq ename "LINE") (eq "PWALLW" (cdr (assoc 8 en))))
  50.                 (setq sp (cdr (assoc 10 en)) ep (cdr (assoc 11 en)))
  51.                 (setq ang (fix (+ 0.5 (/ (* 180 (angle sp ep)) pi))))
  52.                 (if (or (and (>= ang 0) (<= ang 90)) (and (>= ang 270) (<= ang 360)))
  53.                     (setq spl (cons sp spl) epl (cons ep epl))
  54.                 ) ;endif
  55.                 ) ;end "LINE"
  56.                 ((and (eq ename "ARC") (eq "PWALLW" (cdr (assoc 8 en))))
  57.                 (ssadd sn arss)
  58.                 ) ;end arc
  59.                 ((and (eq ename "POLYLINE") (eq "TERRACE" (cdr (assoc 8 en))))
  60.                 (setq tspl nil sn1 sn terhgt (cdr (assoc 39 en)))
  61.                 (while (/= (cdr (assoc 0 (setq en1 (entget (setq sn1 (entnext sn1)))))) "SEQEND")
  62.                 (setq sp (cdr (assoc 10 en1)) tspl (cons sp tspl))
  63.                 )
  64.                 (setq tpl (cons (cons terhgt tspl) tpl))
  65.                 ) ;end "POLYLINE"
  66.                 ((and (eq ename "INSERT") (= "PWINDOW" (cdr (assoc 8 en))))
  67.                 (setq sp (cdr (assoc 10 en)) rang (cdr (assoc 50 en)) sn1 (entnext sn))
  68.                 (setq en1 (entget sn1) en2 (cdr (assoc 1 en1)))
  69.                 (strdv en2) (setq en3 wlist)
  70.                 (setq bn (substr (cdr (assoc 2 en)) 1 3))
  71.                 (if (or (= bn "CCA") (= bn "CCZ")) (progn
  72.                 (strdv (cdr (assoc 1 (entget (entnext sn1)))))
  73.                 (setq rang (atof (nth (1- (length wlist)) wlist)))
  74.                 ))
  75.                 (setq wlength (atoi (nth 1 en3)) wwidth (atoi (nth 2 en3)) wh (atoi (nth 3 en3)) wthick (atoi (nth 4 en3)))
  76.                 (setq sp (list (car (polar (polar sp (+ rang pi) (/ wlength 2)) (- rang (/ pi 2)) (/ wthick 2))) wh))
  77.                 (if (> rang 0) (setq nwlength (* wlength (cos rang))) (setq nwlength wlength))
  78.                 (if (not (or (= rang (/ pi 2.0)) (= rang (* 1.5 pi)))) (setq wl (cons (list sp nwlength wlength wwidth) wl)) )
  79.           ) ;end "INSERT"
  80.           ) ;end cond
  81.           (setq n (1+ n))
  82.        )
  83.    (setq ll (length spl) n0 0 intl nil)
  84.    (setq splx (mapcar 'car spl) eplx (mapcar 'car epl))
  85.    (setq xmin (apply 'min splx) xmax (apply 'max eplx))
  86.    (repeat (1- ll)
  87.       (setq sp (nth n0 spl) ep (nth n0 epl) n1 (1+ n0))
  88.       (repeat (- ll n1)
  89.       (setq sp1 (nth n1 spl) ep1 (nth n1 epl))
  90.       (setq intp (inters sp ep sp1 ep1 t))
  91.       (if (and (/= intp nil) (not (equal (car intp) xmin 0.1)) (not (equal (car intp) xmax 0.1))) (setq intl (cons intp intl)))
  92.       (setq n1 (1+ n1))
  93.       ) ;end repeat
  94.       (setq n0 (1+ n0))
  95.    )
  96.       (if arss (progn
  97.       (setq ssl (sslength arss) n 0)
  98.       (repeat ssl
  99.          (setq sn (ssname arss n))
  100.          (if sn (progn
  101.          (if (setq en (entget sn)) (setq cenp (cdr (assoc 10 en)) rad (cdr (assoc 40 en))))
  102.          (setq n1 0)
  103.          (repeat ssl
  104.          (setq sn1 (ssname arss n1))
  105.          (if sn1 (progn
  106.          (if (setq en1 (entget sn1)) (setq cenp1 (cdr (assoc 10 en1)) rad1 (cdr (assoc 40 en1))))
  107.          (if (equal cenp cenp1 0.1) (progn
  108.          (if (> rad rad1) (progn
  109.                 (setq sp (polar (cdr (assoc 10 en)) (cdr (assoc 50 en)) (cdr (assoc 40 en))))
  110.                 (setq ep (polar (cdr (assoc 10 en)) (cdr (assoc 51 en)) (cdr (assoc 40 en))))
  111.                 (setq ang (angle sp ep))
  112.                 (setq edge (polar (cdr (assoc 10 en)) (- ang 1.57079) (cdr (assoc 40 en))))
  113.                 (setq apl (cons (list sp ep edge) apl))
  114.         ))
  115.          ))
  116.          ))
  117.          (setq n1 (1+ n1))
  118.          )
  119.          ))
  120.          (setq n (1+ n))
  121.       )
  122.       ))
  123.    (setq dx (- inspx xmin))
  124.    (setq n0 0 entl (entlast))
  125.    (repeat fn
  126.    (command "layer" "m" "ewall" "")
  127.    (if (and (= n0 0) (> (abs (- xmax xmin)) 0)) (command "line" (list (+ dx xmin) inspy) (list (+ dx xmax) inspy) ""))
  128.    (if (and (= n0 (1- fn)) (> (abs (- xmax xmin)) 0)) (command "line" (list (+ dx xmin) (+ inspy eh)) (list (+ dx xmax) (+ inspy eh)) ""))
  129.    
  130.    (if (> (abs (- xmax xmin)) 0) (command "line" (list (+ dx xmax) inspy) (list (+ dx xmax) (+ inspy eh)) ""))
  131.    (setq n 0)
  132.    (repeat (length intl)
  133.    (command "line" (list (+ dx (car (nth n intl))) inspy) (list (+ dx (car (nth n intl))) (+ inspy eh)) "")
  134.    (setq n (1+ n))
  135.    )
  136.    (if (> (abs (- xmax xmin)) 0) (command "line" (list (+ dx xmin) inspy) (list (+ dx xmin) (+ inspy eh)) ""))
  137.    (setq apll (length apl) n 0)
  138.    (repeat apll
  139.       (setq ax (nth n apl) axmin (apply 'min (mapcar 'car ax)) axmax (apply 'max (mapcar 'car ax)))
  140.       (if (and (/= axmin xmin) (/= axmin xmax)) (command "line" (list (+ dx axmin) inspy) (list (+ dx axmin) (+ inspy eh)) ""))
  141.       (if (and (/= axmax xmin) (/= axmax xmax)) (command "line" (list (+ dx axmax) inspy) (list (+ dx axmax) (+ inspy eh)) ""))
  142.       (if (and (<= axmin xmin) (<= axmax xmin)) (if (= n0 0) (command "line" (list (+ dx axmin) inspy) (list (+ dx axmax) inspy) "") (if (= n0 (1- fn)) (command "line" (list (+ dx axmin) (+ inspy eh)) (list (+ dx axmax) (+ inspy eh)) ""))))
  143.       (if (and (>= axmax xmax) (>= axmin xmax)) (if (= n0 0) (command "line" (list (+ dx axmin) inspy) (list (+ dx axmax) inspy) "") (if (= n0 (1- fn)) (command "line" (list (+ dx axmin) (+ inspy eh)) (list (+ dx axmax) (+ inspy eh)) ""))))
  144.       (setq n (1+ n))
  145.    )
  146.    (command "layer" "m" "ewindow" "")
  147.    (setq n 0)
  148.    (repeat (length wl)
  149.       (setq x (nth n wl) sp (list (+ dx (caar x)) (+ inspy (cadar x))) nwlength (cadr x) wlength (caddr x) wwidth (cadddr x))
  150. ;     (setq xx (/ nwlength 100) yy (/ wwidth 100))
  151. ;     (command "insert" "whole" sp xx yy "0" wlength wwidth)
  152.       (setq scal (/ nwlength wlength))
  153.    (if (>= scal 0) (setq scal (/ (fix (* scal 1000.0)) 1000.0)) (setq scal (+ 0.0001 (/ (fix (* (abs scal) 1000.0)) 1000.0))))
  154.       (command "pline" sp "w" scal "" (setq sp1 (polar sp 0 nwlength)) (setq sp2 (polar sp1 1.57079 wwidth)) (polar sp2 pi nwlength) "c")
  155.       (setq n (1+ n))
  156.    )
  157.    (setq n 0 tintl nil)
  158.    (repeat (length tpl)
  159.       (setq x (nth n tpl) txmax (apply 'max (mapcar 'car (cdr x))) terhgt (+ (car x) (* 1.5 (getvar "USERR1"))) txmin (apply 'min (mapcar 'car (cdr x))) tinspy (- inspy (* 1.5 (getvar "USERR1"))))
  160.    (setq n1 0 x (cdr x) ll (length x))
  161.    (if (>= ll 3) (progn
  162.    (repeat (- ll 2)
  163.       (setq sp (nth n1 x) ep (nth (1+ n1) x) n2 (1+ n1))
  164.       (repeat (- ll n2 1)
  165.       (setq sp1 (nth n2 x) ep1 (nth (1+ n2) x))
  166.       (setq intp (inters sp ep sp1 ep1 t))
  167.       (if (and (/= intp nil) (not (equal (car intp) txmin 0.1)) (not (equal (car intp) txmax 0.1))) (setq tintl (cons intp tintl)))
  168.       (setq n2 (1+ n2))
  169.       ) ;end repeat
  170.       (setq n1 (1+ n1))
  171.    )
  172.    )) ;endif
  173.    (command "line" (list (+ dx txmin) tinspy) (list (+ dx txmax) tinspy) "")
  174.    (command "line" (list (+ dx txmin) (+ tinspy terhgt)) (list (+ dx txmax) (+ tinspy terhgt)) "")
  175.    (command "line" (list (+ dx txmin) tinspy) (list (+ dx txmin) (+ tinspy terhgt)) "")
  176.    (setq n1 0)
  177.    (repeat (length tintl)
  178.      (command "line" (list (+ dx (car (nth n1 tintl))) tinspy) (list (+ dx (car (nth n1 tintl))) (+ tinspy terhgt)) "")
  179.      (setq n1 (1+ n1))
  180.    )
  181.    (command "line" (list (+ dx txmax) tinspy) (list (+ dx txmax) (+ tinspy terhgt)) "")
  182.    (setq n (1+ n))
  183.    )
  184.    (setq inspy (+ inspy eh))
  185.    (setq n0 (1+ n0))
  186.    ) ;endrepeat fn
  187.    (if (= flag "File") (progn
  188.    (setq ssa nil ssa (ssadd))
  189.    (while (/= (setq entl (entnext entl)) nil) (ssadd entl ssa))
  190.    (if (findfile (strcat file ".DWG")) (command "wblock" file "Y" "" insp ssa "") (command "wblock" file "" insp ssa "")) ))
  191.    )) ;endif ssget
  192.    (command "layer" "s" olay "")
  193.    (setvar "CMDECHO" 1)
  194.    (setq *error* oer)
  195.    (princ)
  196. )
  197. (defun strdv(rn / loop l x)
  198.        (setq wlist nil loop t)
  199.        (while loop
  200.           (setq l (instr 1 rn " "))
  201.           (if (= l 0) (setq wlist (cons rn wlist) loop nil)
  202.              (progn ;else
  203.              (setq x (substr rn 1 (1- l)))
  204.              (setq wlist (cons x wlist))
  205.              (setq rn (substr rn (1+ l) (- (strlen rn) l)))
  206.              (setq loop t)
  207.              )
  208.           )
  209.        )
  210.        (setq wlist (reverse wlist))
  211. )
  212. (defun instr(st s0 s00 / l n loop x n0 l0)
  213.    (setq l (+ (- (strlen s0) st) 1) l0 0 n0 st n 1 loop t)
  214.    (while (and (<= n l) loop)
  215.       (setq x (substr s0 n0 1))
  216.       (if (eq x s00) (setq loop nil l0 n0) (setq n0 (1+ n0) n (1+ n)))
  217.    )
  218.    (eval l0)
  219. )
  220.