home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / ARCWALL.LSP < prev    next >
Encoding:
Text File  |  1992-01-28  |  11.8 KB  |  270 lines
  1. (vmon)
  2.  
  3. (defun awerr(s)
  4.    (if (/= s "Function cancelled")
  5.        (princ (strcat "\nError:" s))
  6.    )
  7.    (command)
  8.    (command "layer" "s" "0" "")
  9.    (command "text" "s" "hz")
  10.    (command)
  11.    (setvar "cmdecho" 1)
  12.    (setvar "pickbox" pib)
  13.    (setvar "highlight" 1)
  14.    (setvar "coords" 0)
  15.    (setq *error* oer)
  16.   (princ)
  17. )
  18.  
  19. (defun instr(st s0 s00 / l n loop x n0 l0)
  20.    (setq l (+ (- (strlen s0) st) 1) l0 0 n0 st n 1 loop t)
  21.    (while (and (<= n l) loop)
  22.       (setq x (substr s0 n0 1))
  23.       (if (eq x s00) (setq loop nil l0 n0) (setq n0 (1+ n0) n (1+ n)))
  24.    )
  25.    (eval l0)
  26. )
  27.  
  28. (defun strdv(rn / loop l x)
  29.        (setq wlist nil loop t)
  30.        (while loop
  31.           (setq l (instr 1 rn " "))
  32.           (if (= l 0) (setq wlist (cons rn wlist) loop nil)
  33.              (progn ;else
  34.              (setq x (substr rn 1 (1- l)))
  35.              (setq wlist (cons x wlist))
  36.              (setq rn (substr rn (1+ l) (- (strlen rn) l)))
  37.              (setq loop t)
  38.              )
  39.           )
  40.        )
  41.        (setq wlist (reverse wlist))
  42. )
  43.  
  44. (defun achkmc(c / l0 l1 l2 xh wd hgt ch)
  45.    (setq wlt nil)
  46.    (if (and (> (setq l0 (instr 1 c "=")) 0) (> (setq l1 (instr 1 c "*")) 0) (= (setq l2 (instr 1 c "@")) 0) (> l1 l0)) (progn
  47.    (setq xh (substr c 1 (- l0 1)) wd (substr c (+ l0 1) (- l1 l0 1)) hgt (substr c (+ l1 1)))
  48.    (if (and (findfile (strcat xh ".dwg")) (> (atoi wd) 0) (> (atoi hgt) 0)) (setq lop nil wlt (list xh wd hgt)) (princ "*Error!*"))) (princ "*Error*"))
  49. )
  50.  
  51. (defun dtr(a)
  52.    (/ (* 180.0 a) pi)
  53. )
  54.  
  55. (setq w 370 sd 250 wmes1 "C-1" whgt "900")
  56.  
  57. (defun C:ARCWALL(/ sn mp bn x x1 pib oer r1 r2 r3 r4 sp1 sp2 sp3 sp4 ep1 ep2 ep3 ep4 sa1 ea1 ma1 mp1 mp2 sn1 sn2 en1 en2 sp ep cp en p1 p2 insp a1 r loop lop lp fg xh one one0 o1 o2 o3 o4 mc wlt l n n0 ss)
  58.    (setvar "cmdecho" 0)
  59.    (setvar "highlight" 0)
  60.    (setq pib (getvar "pickbox"))
  61.    (setq oer *error* *error* awerr)
  62.    (princ "\n╟╜║± <")
  63.    (princ w)
  64.    (setq x (getint ">:"))
  65.    (if (/= x nil) (setq w x))
  66.    (princ "\n═Γ╟╜║± <")
  67.    (princ sd)
  68.    (setq x (getint ">:"))
  69.    (if (/= x nil) (setq sd x))
  70.    (initget 1 "Center")
  71.    (setq sp (getpoint "\n╘░╨─C/<╞≡╡π>:") flag nil)
  72.    (if (= sp "Center") (progn
  73.        (setq cp (getpoint "\n╘░╨─:"))
  74.        (setq sp (getpoint "\n╞≡╡π:"))
  75.        (setq ep (getpoint "\n╓╒╡π:"))
  76.    )
  77.    (progn
  78.        (initget 1 "Center End")
  79.        (setq sp1 (getpoint "\n╘░╨─C/╓╒╡πE/<╡┌╢■╡π>:"))
  80.        (cond ((= sp1 "Center") (setq cp (getpoint "\n╘░╨─:"))
  81.                                (setq ep (getpoint "\n╓╒╡π:")))
  82.              ((= sp1 "End") (setq ep (getpoint "\n╓╒╡π:"))
  83.                             (setq cp (getpoint "\n╘░╨─:")))
  84.              (t (setq ep (getpoint "\n╓╒╡π:") flag t))
  85.         )
  86.    ))
  87.    (if (= (tblsearch "layer" "pwalln") nil)(command "layer" "n" "pwalln" "c" 15 "pwalln" ""))
  88.    (if (= (tblsearch "layer" "pwallw") nil)(command "layer" "n" "pwallw" ""))
  89.    (command "layer" "s" "pwalln" "")
  90.    (if flag (progn
  91.        (command "arc" sp sp1 ep)
  92.        (setq sn (entlast))
  93.        )
  94.        (progn
  95.        (command "arc" "c" cp sp ep)
  96.        (setq sn (entlast))
  97.        )
  98.    )
  99.    (setq en (entget sn) r (cdr (assoc 40 en)) a1 (cdr (assoc 50 en)) a2 (cdr (assoc 51 en)))
  100.    (setq insp (cdr (assoc 10 en)))
  101.    (setq p1 (polar insp a1 (- r 100)) p2 (polar insp a1 (+ r 100)))
  102.    (command "offset" sd (list sn (polar insp a1 r)) p2 "")
  103.    (setq sn1 (entlast) en1 (entget sn1))
  104.    (command "change" sn1 "" "p" "la" "pwallw" "")
  105.    (command "offset" (- w sd) (list sn (polar insp a1 r)) p1 "")
  106.    (setq sn2 (entlast) en2 (entget sn2))
  107.    (command "erase" sn "")
  108.    (setq loop t fg t)
  109.    (while loop
  110.    (princ "\n▓Θ╤»?/┤░╠¿╕▀H/╫░╚δL/┤µ┼╠S/╘∞▒φM/═╦│÷X/\n╚▒╩í<")
  111.    (princ wmes1)
  112.    (initget "? M X L S H")
  113.    (setq x (strcase (getstring ">:")))
  114.    (if (/= x "") (setq wmes1 x))
  115.    (cond 
  116.         ((= wmes1 "H") (princ "\n┤░╠¿╕▀ <")
  117.                       (princ whgt)
  118.                       (setq x (getstring ">: "))
  119.                       (if (/= x "") (setq whgt x)) )
  120.         ((= wmes1 "L") (setq lop t)
  121.                       (while lop
  122.                       (setq fnm (getstring "\n╬─╝■├√: "))
  123.                       (if (findfile (strcat fnm ".mc")) (progn
  124.                       (setq mclist nil)
  125.                       (setq f (open (strcat fnm ".mc") "r"))
  126.                       (while (/= (setq rn (read-line f)) nil)
  127.                          (strdv rn)
  128.                          (setq mclist (cons wlist mclist))
  129.                       )
  130.                     (close f)
  131.                       (setq lop nil))
  132.                       (princ "**╬─╝■├╗╒╥╡╜!**"))
  133.                       ))
  134.          ((= wmes1 "S") (setq lop t)
  135.                        (while lop
  136.                        (setq fnm (getstring "\n╬─╝■├√: "))
  137.                        (if (findfile (strcat fnm ".mc")) (progn
  138.                        (initget "Y N")
  139.                        (setq x (getkword "**╬─╝■╥╤┤µ╘┌, ╓╪╨┤┬≡ <N>**"))
  140.                        ) (setq x "Y"))
  141.                       (if (= x "Y") (progn
  142.                        (setq f (open (strcat fnm ".mc") "w"))
  143.                        (setq n 0 l (length mclist))
  144.                        (repeat l
  145.                          (setq one (nth n mclist))
  146.                          (write-line (strcat (nth 0 one) " " (nth 1 one) " " (nth 2 one) " " (nth 3 one)) f)
  147.                          (setq n (1+ n))
  148.                       )
  149.                       (close f)
  150.                       (setq lop nil)
  151.                       ))
  152.                       ) )
  153.          ((= wmes1 "M") (princ "\n├┼┤░╨═║┼ <C-1>:")
  154.                        (setq x (strcase (getstring)))
  155.                        (if (= x "") (setq xh "C-1") (setq xh x))
  156.                        (if (setq one (assoc xh mclist)) (progn
  157.                        (setq lop t)
  158.                        (while lop
  159.                        (princ "\n├┼┤░╩²╛▌ <")
  160.                        (setq one0 (cdr one) o1 (nth 0 one0) o2 (nth 1 one0) o3 (nth 2 one0))
  161.                        (princ (setq mc (strcat (strcase o1) "=" o2 "*" o3)))
  162.                        (setq x (strcase (getstring ">:")))
  163.                        (if (= x "") (setq mc mc) (setq mc x))
  164.                        (achkmc mc)
  165.                       )
  166.                       (setq mclist (subst (cons xh wlt) one mclist))
  167.                       )
  168.                       (progn ;else
  169.                       (setq lop t)
  170.                       (while lop
  171.                       (while (= (setq x (strcase (getstring "\n├┼┤░╩²╛▌:"))) ""))
  172.                       (achkmc x))
  173.                       (setq mclist (cons (cons xh wlt) mclist))
  174.                       )
  175.                       ) ;endif
  176.                      ) ;end cond1
  177.          ((= wmes1 "?") (setq l (length mclist) n 0)
  178.                        (setq wmes "N")
  179.                        (if (> l 0) (progn
  180.                        (princ "\n**╨═║┼ ┐Θ├√ ┐φ╢╚ ╕▀╢╚ **")
  181.                        (repeat l
  182.                           (setq x (nth n mclist))
  183.                           (princ "\n   ")
  184.                           (setq n0 0)(repeat (length x) (princ (read (nth n0 x))) (princ " ") (setq n0 (1+ n0)))
  185.                           (setq n (1+ n))
  186.                        ))
  187.                       (princ "\n*├┼┤░▒φ╓╨╬▐╩²╛▌*")
  188.                       ))
  189.          ((= wmes1 "X") (setq loop nil fg nil))
  190.          (t (if (setq one (assoc wmes1 mclist)) (progn
  191.             (setq lp t)
  192.             (while lp
  193.             (initget "Undo X")
  194.             (setq sp (getpoint "\n╗╪═╦U/═╦│÷X/<├┼┤░╞≡╡π>:"))
  195.             (cond ((= sp "Undo") (command "undo" "end" "u"))
  196.                   ((= sp "X") (setq lp nil wmes1 sp))
  197.                   (t (setvar "coords" 2)
  198.                      (setq ep (getpoint sp "\n├┼┤░╓╒╡π:"))
  199.                      (setvar "coords" 0)
  200.                      (command "undo" "g")
  201.                      (setq r1 (cdr (assoc 40 en1)) r2 (cdr (assoc 40 en2)))
  202.                      (setq sa1 (angle insp sp) ea1 (angle insp ep) ma1 (- ea1 sa1))
  203.                      (if (< ma1 0) (setq ma1 (+ sa1 (/ (+ (* 2 pi) ma1) 2.0))) (setq ma1 (+ sa1 (/ ma1 2.0))))
  204.                      (setq sp1 (polar insp sa1 r1) ep1 (polar insp ea1 r1))
  205.                      (setq sp2 (polar insp sa1 r2) ep2 (polar insp ea1 r2))
  206.                      (setq mp1 (polar insp ma1 r1) mp2 (polar insp ma1 r2))
  207.                      (setq mp (polar mp2 (angle mp2 mp1) (/ (- r1 r2) 2.0)))
  208.                      (setvar "pickbox" 1)
  209.                      (setq sn1 (ssname (ssget mp1) 0))
  210.                      (setq sn2 (ssname (ssget mp2) 0))
  211.                      (setvar "pickbox" pib)
  212.                      (command "break" sn1 sp1 ep1)
  213.                      (command "break" sn2 sp2 ep2)
  214.                      (command "layer" "m" "pwindow" "")
  215.                      (command "line" sp1 sp2 "" "line" ep1 ep2 "")
  216.                      (command "color" 2)
  217.                      (setq dr (/ (- r1 r2) 3.0) r3 (+ r2 dr) r4 (- r1 dr))
  218.                      (setq sp3 (polar insp sa1 r3) ep3 (polar insp ea1 r3))
  219.                      (setq sp4 (polar insp sa1 r4) ep4 (polar insp ea1 r4))
  220.                      (if (= (substr (setq bn (nth 1 one)) 1 2) "CC") (progn
  221.                      (setq sn nil sn (ssadd))
  222.                      (command "arc" sp3 "c" insp ep3)
  223.                      (ssadd (entlast) sn)
  224.                      (command "arc" sp4 "c" insp ep4)
  225.                      (ssadd (entlast) sn)
  226.                      (command "arc" sp1 "c" insp ep1)
  227.                      (ssadd (entlast) sn)
  228.                      (command "arc" sp2 "c" insp ep2)
  229.                      (ssadd (entlast) sn)
  230.                      (setvar "aflags" 1)
  231.                      (command "attdef" "" "x" "" "" "s" "standard" mp1 (* 3 (getvar "userr1")) 0)
  232.                      (ssadd (entlast) sn)
  233.                      (command "attdef" "" "x1" "" "" mp1 (* 3 (getvar "userr1")) 0)
  234.                      (ssadd (entlast) sn)
  235.                      (setq bn (strcat "CCA" (rtos (car mp) 2 0) (rtos (cadr mp) 2 0)))
  236.                      (command "color" "bylayer")
  237.                      (command "block" bn mp sn "")
  238.                      (setq x (strcat wmes1 " " (itoa (fix (distance sp1 ep1))) " " (nth 3 one) " " whgt " " (itoa w)))
  239.                      (setq x1 (strcat wmes1 " " (rtos sa1 2 4) " " (rtos ea1 2 4) " " (rtos r1 2 4) " " (rtos r2 2 4) " " (nth 3 one) " " whgt " " (itoa w) " " (rtos (angle sp1 ep1) 2 4)))
  240.                      (command "insert" bn mp "XYZ" 1 1 1 0 x x1)
  241.                      ) ;endprogn "CC"
  242.                      (progn ;else
  243.                      (setq sn (entlast) ss nil ss (ssadd))
  244.                      (command "insert" bn mp (/ (distance sp3 ep3) 100.0) "" (/ (* (angle sp3 ep3) 180.0) pi) "")
  245.                      (command "explode" (entlast))
  246.                      (while (/= (setq sn (entnext sn)) nil) (ssadd sn ss))
  247.                      (setvar "aflags" 1)
  248.                      (command "attdef" "" "x1" "" "" mp1 (* 3 (getvar "userr1")) 0)
  249.                      (ssadd (entlast) ss)
  250.                      (setq bn (strcat "CCA" (rtos (car mp) 2 0) (rtos (cadr mp) 2 0)))
  251.                      (command "block" bn mp ss "")
  252.                      (setq x (strcat wmes1 " " (itoa (fix (distance sp1 ep1))) " " (nth 3 one) " 0 " (itoa w)))
  253.                      (setq x1 (strcat wmes1 " " (rtos sa1 2 4) " " (rtos ea1 2 4) " " (rtos r1 2 4) " " (rtos r2 2 4) " " (nth 3 one) " 0 " (itoa w) " " (rtos (angle sp1 ep1) 2 4)))
  254.                      (command "insert" bn mp "xyz" 1 1 0.01 0 x x1)
  255.                      )) ;endif
  256.                      (command "undo" "end")
  257.                      )) ;end cond
  258.                      )) ;endwhile endprogn
  259.                      (princ "*Not found*"))
  260.                      ) ;endif
  261.     ) ;end cond
  262.     ) ;end while
  263.     (command "layer" "s" "0" "")
  264.     (command "text" "s" "hz")
  265.     (command)
  266.     (setvar "cmdecho" 1)
  267.     (setq *error* oer)
  268.     (princ)
  269. )
  270.