home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / ISWIN.LSP < prev    next >
Encoding:
Text File  |  1992-01-30  |  12.9 KB  |  286 lines
  1. (setq dat "CCC=1800*1800" whight "900")
  2.  
  3. (defun iswinerr(s)
  4.   (if (/= s "Function cancelled")
  5.       (princ (strcat "\nError:" s))
  6.   )
  7.   (setvar "osmode" 0)
  8.   (command "layer" "s" "0" "")
  9.   (setvar "cmdecho" 1)
  10.   (setq *error* oer)
  11.   (princ)
  12. )
  13.  
  14. (defun instr(st s0 s00 / l n loop x n0 l0)
  15.    (setq l (+ (- (strlen s0) st) 1) l0 0 n0 st n 1 loop t)
  16.    (while (and (<= n l) loop)
  17.       (setq x (substr s0 n0 1))
  18.       (if (eq x s00) (setq loop nil l0 n0) (setq n0 (1+ n0) n (1+ n)))
  19.    )
  20.    (eval l0)
  21. )
  22.  
  23. (defun strdv(rn / loop l x)
  24.        (setq wlist nil loop t)
  25.        (while loop
  26.           (setq l (instr 1 rn " "))
  27.           (if (= l 0) (setq wlist (cons rn wlist) loop nil)
  28.              (progn ;else
  29.              (setq x (substr rn 1 (1- l)))
  30.              (setq wlist (cons x wlist))
  31.              (setq rn (substr rn (1+ l) (- (strlen rn) l)))
  32.              (setq loop t)
  33.              )
  34.           )
  35.        )
  36.        (setq wlist (reverse wlist))
  37. )
  38.  
  39. (defun chkmc(c / l0 l1 l2 xh wd hgt ch)
  40.    (setq wlt nil)
  41.    (if (and (> (setq l0 (instr 1 c "=")) 0) (> (setq l1 (instr 1 c "*")) 0) (> l1 l0) (= (instr 1 c "@") 0)) (progn
  42.    (setq xh (substr c 1 (- l0 1)) wd (substr c (+ l0 1) (- l1 l0 1)) hgt (substr c (+ l1 1)))
  43.    (if (and (findfile (strcat xh ".dwg"))(> (atoi wd) 0) (> (atoi hgt) 0) (> (strlen c) l1))(setq lop nil wlt (list xh wd hgt)) (princ "*├┼┤░╩²╛▌╙╨┤φ*"))) (princ "*├┼┤░╩²╛▌│÷┤φ*"))
  44. )
  45.  
  46. (defun c:iswin(/ oer thns lop x x1 wh bn sx sy sz sz0 whigh wwidth loop ssn entl ent1 entp ss en ename elay p1 ths bulge
  47.   wth ent2 ent p2 sp ep ang1 ang2 angm pi2 ssbl ssal sp1 ep1 sp2 ep2 sp3 ep3 sp4 ep4 att att1 insp1 insp2 bln1 bln2 bln p3 p4
  48.   p5 p6 ip ang cen r bln bnn sz0 entnx ennx)
  49.   (setvar "cmdecho" 0)
  50.   (setq oer *error* *error* iswinerr)
  51.   (setq thns (getvar "thickness"))
  52.   (setq lop t)
  53.   (while lop
  54.   (initget "Hight")
  55.   (princ "\n┤░╠¿╕▀H/├┼┤░╩²╛▌ <")
  56.   (princ dat)
  57.   (setq x (getstring ">: "))
  58.   (cond ((= (strcase x) "H") (princ "\n┤░╠¿╕▀ <")
  59.                    (princ whight)
  60.                    (setq x1 (getstring ">: "))
  61.                    (if (/= x1 "") (setq whight x1))
  62.          )
  63.    (t (if (/= x "") (setq dat x))
  64.       (chkmc dat)
  65.     ))
  66.   ) ;endwhile
  67.   (setq wh (atoi whight) bn (nth 0 wlt) sx (/ (setq wwidth (atoi (nth 1 wlt))) 100.0) sz (/ (setq whigh (atoi (nth 2 wlt))) 100.0))
  68.   (setq loop t)
  69.   (while loop
  70.   (setq ssn (nentsel "\nSelect wall: "))
  71.   (if ssn (progn
  72.   (if (= (length ssn) 2)(setq ent1 (car ssn) entp (cadr ssn) ss (entget (ssname (ssget entp) 0))) (setq ent1 (car (last ssn))))
  73.   (setq en (entget ent1) ename (cdr (assoc 0 en)) elay (cdr (assoc 8 en)))
  74.   (cond ((= ename "VERTEX")
  75.   (setq p1 (cdr (assoc 10 (entget ent1))) ths (cdr (assoc 39 (entget ent1))))
  76.   (setq bulge (cdr (assoc 42 (entget ent1))))
  77.   (setq wth (fix (+ 0.5 (cdr (assoc 40 (entget ent1)))))) (if (or (= (strcase bn) "MMH")(= (strcase (substr bn 1 2)) "CC")) (setq sy (/ wth 10.0)) (setq sy sx))
  78.   (if (= ths nil) (setq ths 0) (setq ths (fix (+ ths 0.5))))
  79.   (setq ent2 (entnext ent1))
  80.   (setq ename (cdr (assoc 0 (entget ent2))))
  81.   (if (= "SEQEND" ename) (progn
  82.     (setq ent (entget (entnext (cdr (assoc -2 (entget ent2))))))
  83.     (setq p2 (cdr (assoc 10 ent))) )
  84.     (setq p2 (cdr (assoc 10 (entget ent2))))
  85.   )
  86.   (while (/= "SEQEND" (cdr (assoc 0 (entget ent2))))
  87.      (setq ent2 (entnext ent2))
  88.   )
  89.   (setq ent1 (cdr (assoc -2 (entget ent2))))
  90.   (cond ((equal entp p1)
  91.     (setq sp (getpoint entp "\nLast point:"))
  92.     (setq ep (getpoint entp "\nNext point:"))
  93.     (setq ang1 (angle sp p1) ang2 (angle p1 ep))
  94.     (setq angm (- ang2 ang1))
  95.     (if (< angm 0) (setq angm (+ ang2 (/ (+ (* 2 pi) angm) 2.0))) (setq angm (+ ang2 (/ angm 2.0))))
  96.     (setq pi2 (/ pi 2.0) ssbl nil ssbl (ssadd) ssal nil ssal (ssadd))
  97.     (setq sp1 (polar sp (+ ang1 pi2) (+ (/ wth 2.0) 1)))
  98.     (setq ep1 (polar p1 (+ ang1 pi2) (+ (/ wth 2.0) 1)))
  99.     (setq sp3 (polar p1 (+ ang2 pi2) (+ (/ wth 2.0) 1)))
  100.     (setq ep3 (polar ep (+ ang2 pi2) (+ (/ wth 2.0) 1)))
  101.     (setq ep1 (inters sp1 ep1 sp3 ep3 nil) sp3 ep1)
  102.     (setq sp2 (polar sp (- ang1 pi2) (+ (/ wth 2.0) 1)))
  103.     (setq ep2 (polar p1 (- ang1 pi2) (+ (/ wth 2.0) 1)))
  104.     (setq sp4 (polar p1 (- ang2 pi2) (+ (/ wth 2.0) 1)))
  105.     (setq ep4 (polar ep (- ang2 pi2) (+ (/ wth 2.0) 1)))
  106.     (setq ep2 (inters sp2 ep2 sp4 ep4 nil) sp4 ep2)
  107.     (setvar "elevation" 0)
  108.     (setvar "thickness" 100.0)
  109.     (command "color" 2)
  110.     (command "pline" ep1 "w" 0 0 sp1 sp2 ep2 "")
  111.     (ssadd (entlast) ssal)
  112.     (setq att1 (strcat (rtos (car sp1) 2 2) " " (rtos (cadr sp1) 2 2) " " (rtos (car sp2) 2 2) " " (rtos (cadr sp2) 2 2) " " (rtos (car ep2) 2 2) " " (rtos (cadr ep2) 2 2) " " (rtos (car ep1) 2 2) " " (rtos (cadr ep1) 2 2) " " (rtos ang1 2 4)))
  113.     (command "pline" sp4 "w" 0 0 ep4 ep3 sp3 "")
  114.     (ssadd (entlast) ssbl)
  115.     (setq att2 (strcat (rtos (car sp3) 2 2) " " (rtos (cadr sp3) 2 2) " " (rtos (car sp4) 2 2) " " (rtos (cadr sp4) 2 2) " " (rtos (car ep4) 2 2) " " (rtos (cadr ep4) 2 2) " " (rtos (car ep3) 2 2) " " (rtos (cadr ep3) 2 2) " " (rtos ang2 2 4)))
  116.     (setq sp1 (polar sp (+ ang1 pi2) (/ wth 6.0)))
  117.     (setq ep1 (polar p1 (+ ang1 pi2) (/ wth 6.0)))
  118.     (setq sp3 (polar p1 (+ ang2 pi2) (/ wth 6.0)))
  119.     (setq ep3 (polar ep (+ ang2 pi2) (/ wth 6.0)))
  120.     (setq ep1 (inters sp1 ep1 sp3 ep3 nil) sp3 ep1)
  121.     (setq sp2 (polar sp (- ang1 pi2) (/ wth 6.0)))
  122.     (setq ep2 (polar p1 (- ang1 pi2) (/ wth 6.0)))
  123.     (setq sp4 (polar p1 (- ang2 pi2) (/ wth 6.0)))
  124.     (setq ep4 (polar ep (- ang2 pi2) (/ wth 6.0)))
  125.     (setq ep2 (inters sp2 ep2 sp4 ep4 nil) sp4 ep2)
  126.   (setq insp1 (inters sp1 ep2 sp2 ep1) insp2 (inters sp4 ep3 sp3 ep4))
  127.     (setvar "thickness" 0)
  128.     (command "pline" sp1 ep1 "")(ssadd (entlast) ssal)
  129.     (command "pline" sp2 ep2 "")(ssadd (entlast) ssal)
  130.     (command "pline" sp3 ep3 "")(ssadd (entlast) ssbl)
  131.     (command "pline" sp4 ep4 "")(ssadd (entlast) ssbl)
  132.   (setvar "aflags" 1)
  133.   (command "attdef" "" "h" "" "" p1 (* (getvar "userr1") 3) 0)
  134.   (ssadd (entlast) ssal)
  135.   (command "attdef" "" "h1" "" "" p1 (* (getvar "userr1") 3) 0)
  136.   (ssadd (entlast) ssal)
  137.   (command "attdef" "" "h" "" "" p1 (* (getvar "userr1") 3) 0)
  138.   (ssadd (entlast) ssbl)
  139.   (command "attdef" "" "h1" "" "" p1 (* (getvar "userr1") 3) 0)
  140.   (ssadd (entlast) ssbl)
  141.   (setq bln1 (strcat "CCZ" (rtos (car sp) 2 0) (rtos (cadr sp) 2 0)))
  142.   (setq bln2 (strcat "CCZ" (rtos (car ep) 2 0) (rtos (cadr ep) 2 0)))
  143.   (setvar "expert" 2)
  144.   (command "block" bln1 insp1 ssal "")
  145.   (command "block" bln2 insp2 ssbl "")
  146.   (setvar "expert" 0)
  147.   (command "layer" "m" "pwindow" "")
  148.   (setq att (strcat (itoa ths) " " (itoa wth)))
  149.   (command "insert" bln1 (list (car insp1) (cadr insp1) wh) "xyz" 1 1 sz 0 att att1)
  150.   (command "insert" bln2 (list (car insp2) (cadr insp2) wh) "xyz" 1 1 sz 0 att att2)
  151.   (command "color" "bylayer")
  152.   ) ;cz
  153.   (T (if (= bulge 0) (progn
  154.   (setq ang (angle p1 p2))
  155.   (command "insert" bn "x" sx "y" sy "z" sz "r" (/ (* 180 ang) pi) pause 0)
  156.   (setq entl (entlast))
  157.   (setq ip (cdr (assoc 10 (entget entl))))
  158.   (entdel entl)
  159.   (setq ip (inters ip (polar ip (+ ang 1.57079) 50) p1 p2 nil))
  160.   (setq p3 (polar ip (+ ang pi) (/ wwidth 2.0)) p4 (polar ip ang (/ wwidth 2.0)))
  161.   (setq pi2 (/ pi 2.0))
  162.   (if (= (substr (strcase bn) 1 2) "MM")(command "break" ent1 p3 p4))
  163.   (setq p5 (polar p3 (+ ang pi2) (/ wth 2.0)) p7 (polar p4 (+ ang pi2) (/ wth 2.0)))
  164.   (setq p6 (polar p3 (- ang pi2) (/ wth 2.0)) p8 (polar p4 (- ang pi2) (/ wth 2.0)))
  165.   (if (= (substr (strcase bn) 1 2) "CC") (setq ip (list (car ip) (cadr ip) wh)))
  166. ; (command "layer" "m" "pwall" "")
  167. ; (setvar "thickness" 0)
  168. ; (command "line" p5 p6 "")
  169. ; (command "line" p7 p8 "")
  170.   (command "layer" "m" "pwindow" "")
  171.   (setq att (strcat (itoa ths) " " (itoa wth)))(command "insert" bn "x" sx "y" sy "z" sz "r" (/ (* 180 ang) pi) ip att)
  172.   ) ;endprogn bugle
  173.   (progn ;<>0
  174.   (setq ang (* 4 (atan bulge)) ang1 (angle p1 p2))
  175.   (if (>= ang pi)
  176.    (setq ang (- (angle p1 p2) (- (/ pi 2.0) (/ (- (* 2 pi) ang) 2.0))))
  177.    (setq ang (+ (angle p1 p2) (- (/ pi 2.0) (/ ang 2.0))))
  178.   )
  179.   (if (equal (- (angle p1 p2) ang) 0) (setq r (/ (distance p1 p2) 2.0)) (setq r (/ (/ (distance p1 p2) 2.0) (cos (abs (- (angle p1 p2) ang))))))
  180.   (setq cen (polar p1 ang r) r (abs r))
  181.   (setq sp (getpoint cen "\nStart point: "))
  182.   (setq ep (getpoint cen "\nEnd point: "))
  183.   (setq ang1 (angle cen sp) ang2 (angle cen ep) angm (- ang2 ang1))
  184.   (if (< angm 0) (setq angm (+ ang1 (/ (+ (* 2 pi) angm) 2.0))) (setq angm (+ ang1 (/ angm 2.0))))
  185.   (setq ip (polar cen angm r))
  186.   (if (= (strcase (substr bn 1 2)) "MM") (progn
  187.   (setq sp (polar cen (setq ang1 (angle cen sp)) r))
  188.   (setq ep (polar cen (setq ang2 (angle cen ep)) r))
  189.   (setq sx (/ (distance sp ep) 100.0) sy sx)
  190.   (command "break" ent1 sp ep)
  191.   (command "layer" "m" "pwindow" "")
  192.   (setq bln (strcat "CCAM" (rtos (car ip) 2 0) (rtos (cadr ip) 2 0)))
  193.   (setq att (strcat (itoa ths) " " (itoa wth)))
  194.   (setq att1 (strcat (rtos (car sp) 2 2) " " (rtos (cadr sp) 2 2) " " (rtos (car cen) 2 2) " " (rtos (cadr cen) 2 2) " " (rtos (car ep) 2 2) " " (rtos (cadr ep) 2 2)))
  195.   (setq entl (entlast) ssbl nil ssbl (ssadd))
  196.   (command "insert" bn ip "xyz" 1 1 1 0 att)
  197.   (command "explode" (entlast))
  198.   (while (/= (setq entl (entnext entl)) nil) (ssadd entl ssbl))
  199.   (setvar "aflags" 1)
  200.   (command "attdef" "" "h1" "" "" ip (* 3 (getvar "userr1")) 0)
  201.   (ssadd (entlast) ssbl)
  202.   (command "block" bln ip ssbl "")
  203.   (command "insert" bln ip "xyz" sx sy sz (/ (* 180 (angle sp ep)) pi) att att1)
  204.   )(progn
  205.   (setq sp1 (polar cen ang1 (- r (/ wth 2.0) 2)))
  206.   (setq ep1 (polar cen ang2 (- r (/ wth 2.0) 2)))
  207.   (setq sp2 (polar cen ang1 (+ r (/ wth 2.0) 2)))
  208.   (setq ep2 (polar cen ang2 (+ r (/ wth 2.0) 2)))
  209.   (setvar "elevation" 0)
  210.   (setvar "thickness" 100.0)
  211.   (setq ssbl nil ssbl (ssadd) oldc (getvar "CECOLOR"))
  212.   (command "color" 2)
  213.   (command "arc" sp1 "c" cen ep1)
  214.   (ssadd (entlast) ssbl)
  215.   (command "arc" sp2 "c" cen ep2)
  216.   (ssadd (entlast) ssbl)
  217.   (command "line" sp1 sp2 "")
  218.   (ssadd (entlast) ssbl)
  219.   (command "line" ep1 ep2 "")
  220.   (ssadd (entlast) ssbl)
  221.   (setq sp3 (polar cen ang1 (- r (/ wth 6.0))))
  222.   (setq ep3 (polar cen ang2 (- r (/ wth 6.0))))
  223.   (setq sp4 (polar cen ang1 (+ r (/ wth 6.0))))
  224.   (setq ep4 (polar cen ang2 (+ r (/ wth 6.0))))
  225.   (setvar "thickness" 0)
  226.   (command "arc" sp3 "c" cen ep3)
  227.   (ssadd (entlast) ssbl)
  228.   (command "arc" sp4 "c" cen ep4)
  229.   (ssadd (entlast) ssbl)
  230.   (setvar "aflags" 1)
  231.   (command "attdef" "" "h" "" "" ip (* (getvar "userr1") 3) 0)
  232.   (ssadd (entlast) ssbl)
  233.   (command "attdef" "" "h1" "" "" ip (* (getvar "userr1") 3) 0)
  234.   (ssadd (entlast) ssbl)
  235.   (setq bln (strcat "CCA" (rtos (car ip) 2 0) (rtos (cadr ip) 2 0)))
  236.   (command "block" bln ip ssbl "")
  237.   (command "layer" "m" "pwindow" "")
  238.   (setq att (strcat (itoa ths) " " (itoa wth)))
  239.   (setq att1 (strcat (rtos (car sp) 2 2) " " (rtos (cadr sp) 2 2) " " (rtos (car cen) 2 2) " " (rtos (cadr cen) 2 2) " " (rtos (car ep) 2 2) " " (rtos (cadr ep) 2 2)))
  240.   (command "insert" bln (list (car ip) (cadr ip) wh) "xyz" 1 1 sz 0 att att1)
  241.   (command "color" "bylayer")
  242.   )) ;if MMM
  243.   )) ;if bulge
  244.   )) ;end cond
  245.   )
  246.   ((and (= ename "INSERT") (= elay "PWINDOW"))
  247.   (setq bnn (cdr (assoc 2 en)) ip (cdr (assoc 10 en)) sz0 (cdr (assoc 43 en)))
  248.   (if (or (= (substr bnn 1 3) "CCA") (= (substr bnn 1 3) "CCZ")) (progn
  249.   (setq entnx (entnext ent1) att (cdr (assoc 1 (setq ennx (entget entnx)))))
  250.   (setq ths (atoi (substr att 1 (- (instr 1 att " ") 1))))
  251.   (setq att (strcat (itoa wh) "$ " (substr att (+ (instr 1 att " ") 1))))
  252.   (setq ennx (subst (cons 1 att) (assoc 1 ennx) ennx))
  253.   (entmod ennx)
  254.    (command "copy" ent1 "" ip (list (car ip) (cadr ip) wh))
  255.    (setq entl (entlast) entnx (entnext entl))
  256.    (setq en (entget entl) ennx (entget entnx) att (cdr (assoc 1 ennx)))
  257.    (setq att (substr att (+ (instr 1 att " ") 1)))
  258.    (setq att (strcat (itoa (- ths (+ whigh wh))) " " att " " (rtos (+ (last ip) (* sz0 100.0)) 2 0) "@"))
  259.    (setq en (subst (cons 43 sz) (assoc 43 en) en))
  260.    (entmod en)
  261.    (setq ennx (subst (cons 1 att) (assoc 1 ennx) ennx))
  262.    (entmod ennx)
  263.    )(progn
  264.    (setq sx (cdr (assoc 41 en)) ang (/ (* 180 (cdr (assoc 50 en))) pi))
  265.   (setq entnx (entnext ent1) att (cdr (assoc 1 (setq ennx (entget entnx)))))
  266.   (strdv att) (setq ths (atof (nth 0 wlist)) sy (/ (atof (nth 1 wlist)) 10.0))
  267.   (setq ennx (subst (cons 1 (strcat (itoa wh) "$ " (nth 1 wlist))) (assoc 1 ennx) ennx))
  268.   (entmod ennx)
  269.    (setq att (strcat (rtos (- ths (+ whigh wh)) 2 0) " " (nth 1 wlist) " " (rtos (+ (last ip) (* sz0 100.0)) 2 0) "@"))
  270.   (command "layer" "m" "pwindow" "")
  271.    (command "insert" bn "x" sx "y" sy "z" sz "r" ang (list (car ip) (cadr ip) wh) att)
  272.    ))
  273.   )) ;end cond
  274.   ) (setq loop nil))
  275.   )
  276.   (setq *error* oer)
  277.   (command "layer" "s" "0" "")
  278.   (setvar "cmdecho" 1)
  279.   (setvar "thickness" thns)
  280.   (princ)
  281. )
  282.  
  283. (defun fixp(p)
  284.    (setq p (list (fix (+ (car p) 0.5)) (fix (+ (cadr p) 0.5)) (fix (+ (caddr p) 0.5))))
  285. )
  286.