home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / ROOF.LSP < prev    next >
Encoding:
Text File  |  1992-01-29  |  3.9 KB  |  103 lines
  1. (vmon)
  2.  
  3. (defun rooferr(s)
  4.    (if (/= s "Function cancelled")
  5.        (princ (strcat "\nError:" s))
  6.    )
  7.    (command "layer" "s" "0" "")
  8.    (setvar "cmdecho" 1)
  9.    (setq *error* oer)
  10.    (princ)
  11. )
  12.   
  13. (setq felv 3300.0 clay "TOTHER")
  14.  
  15. (defun C:ROOF(/ x x1 loop sn1 sn2 sn3 en1 en2 en01 en02 sp1 sp2 ep1 ep2 op sp ep ang pl spl bx by sply1 sply2 n n0 n1 ll dx zpl lpl fg dist sn4 fg70 pl0)
  16.    (setvar "CMDECHO" 0)
  17.    (setq oer *error* *error* rooferr)
  18.    (if (/= (+ fh78 fh65 fh72 fh85 fh70) 370) (tst))
  19.    (princ "\n▓π├√ <")(princ clay)
  20.    (setq x (getstring ">: "))
  21.    (if (/= x "") (setq clay (strcase x)))
  22.    (princ "\n╩Σ╚δ╣∞╝ú╧▀╧α╢╘╕▀╢╚ <")
  23.    (princ (fix felv))
  24.    (setq x (getreal ">:"))
  25.    (if (/= x nil) (setq felv x))
  26.    (setq loop t ssp nil ssp (ssadd))
  27.    (while loop
  28.    (while (= nil (setq sn1 (entsel "\n╤í╘±╣∞╝ú╧▀:"))))
  29.    (if (= "POLYLINE" (cdr (assoc 0 (setq en01 (entget (car sn1)))))) (setq loop nil))
  30.    )
  31.    (setq loop t)
  32.    (while loop
  33.    (while (= nil (setq sn2 (entsel "\n╤í╘±╨╬╫┤╞╩├µ╧▀:"))))
  34.    (if (= "POLYLINE" (cdr (assoc 0 (setq en02 (entget (car sn2))))))  (setq loop nil))
  35.    )
  36.    (setq pl nil zpl nil sn3 (car sn1))
  37.    (while (/= "SEQEND" (cdr (assoc 0 (setq en1 (entget (setq sn3 (entnext sn3)))))))
  38.       (setq sp1 (cdr (assoc 10 en1)) pl (cons sp1 pl))
  39.     )
  40.     (if (or (= 9 (cdr (assoc 70 en01))) (= 1 (cdr (assoc 70 en01)))) (setq pl (cons (last pl) pl)))
  41.     (setq zpl (cons (setq pl (reverse pl)) zpl))
  42.     (setq  spl nil sn2 (car sn2))
  43.     (while (/= "SEQEND" (cdr (assoc 0 (setq en2 (entget (setq sn2 (entnext sn2)))))))
  44.        (setq sp2 (cdr (assoc 10 en2)) spl (cons sp2 spl))
  45.      )
  46.     (if (or (= 9 (cdr (assoc 70 en02))) (= 1 (cdr (assoc 70 en02)))) (setq spl (cons (last spl) spl)))
  47.      (setq lpl (length pl) spl (reverse spl))
  48.      (setq splx (mapcar 'car spl) sply (mapcar 'cadr spl))
  49.      (setq bx (nth 0 splx) by (nth 0 sply))
  50.      (setq sp (nth 0 pl) ep (nth 1 pl) ang (angle sp ep) dist (distance sp ep) ep (polar sp ang (/ dist 2.0)))
  51.      (if (>= (setq fg70 (cdr (assoc 70 en01))) 8) (progn (setq en01 (subst (cons 70 (- fg70 8)) (assoc 70 en01) en01)) (entmod en01)))
  52.      (setq n 1)
  53.      (repeat (1- (length splx))
  54.         (setq dx (- (nth n splx) bx))
  55.         (cond ((= dx 0) (setq dx 0.000001 op ep))
  56.               ((> dx 0) (setq op (polar ep (- ang 1.57079) 200)))
  57.               ((< dx 0) (setq dx (- dx) op (polar ep (+ ang 1.57079) 200)))
  58.         )
  59.         (command "offset" dx sn1 (list (car op) (cadr op)) "")
  60.         (ssadd (entlast) ssp)
  61.         (setq n (1+ n))
  62.       )
  63.       (if ssp (progn
  64.       (setq ssl (sslength ssp) n 0)
  65.       (repeat ssl
  66.         (setq pl0 nil sn3 (setq sn4 (ssname ssp n)) n0 0)
  67.         (while (/= "SEQEND" (cdr (assoc 0 (setq en1 (entget (setq sn3 (entnext sn3)))))))
  68.         (setq sp1 (cdr (assoc 10 en1)) pl0 (cons (list (car sp1) (cadr sp1) (caddr (nth n0 pl))) pl0))
  69.         (setq n0 (1+ n0))
  70.         )
  71.         (if (= 1 (cdr (assoc 70 en01))) (setq pl0 (cons (last pl0) pl0)))
  72.         (if (/= (length pl0) lpl) (setq fg t))
  73. (princ "\n**")(princ (list (length pl0) lpl))
  74.         (setq zpl (cons (reverse pl0) zpl))
  75.         (entdel sn4)
  76.         (setq n (1+ n))
  77.       )
  78.       (setq zpl (reverse zpl))
  79.       (setq en01 (subst (cons 70 fg70) (assoc 70 en01) en01))
  80.       (entmod en01)
  81.       (if (not fg) (progn
  82.       (setq ll (length zpl) n 0 x (nth n zpl) ll0 (length x))
  83.       (command "layer" "m" clay "")
  84.       (command "3dmesh" ll ll0)
  85.       (repeat ll
  86.          (setq x (nth n zpl) sply1 (+ (- (nth n sply) by) felv))
  87.          (setq n0 0)
  88.          (repeat ll0
  89.             (setq sp1 (nth n0 x))
  90.             (setq sp1 (list (car sp1) (cadr sp1) (+ (caddr sp1) sply1)))
  91.              (command sp1)
  92.              (setq n0 (1+ n0))
  93.          )
  94.          (setq n (1+ n))
  95.       )
  96.       ) (princ "\n╣∞╝ú╧▀╣╒╡π╛α└δ╠½╜ⁿ"))
  97.       ))
  98.       (command "layer" "s" "0" "")
  99.       (setvar "CMDECHO" 1)
  100.       (setq *error* oer)
  101.       (princ)
  102. )
  103.