home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / LTOF.LSP < prev    next >
Encoding:
Text File  |  1992-01-29  |  12.9 KB  |  257 lines
  1. (vmon)
  2.  
  3. (defun ltoferr(s)
  4.    (if (/= s "Function cancelled")
  5.        (princ (strcat "\nError:" s))
  6.    )
  7.    (command "layer" "s" "0" "")
  8.    (setvar "cmdecho" 1)
  9.    (setvar "surftab1" surtab)
  10.    (setq *error* oer)
  11.    (princ)
  12. )
  13.  
  14. (setq el 3300 fsh "All")
  15.  
  16. (defun C:SINGLE(/ fg oer)
  17.    (setq fg "SINGLE")
  18.    (ltof fg)
  19. )
  20.  
  21. (defun C:DUBBLE(/ fg oer)
  22.    (setq fg "DUBBLE")
  23.    (ltof fg)
  24. )
  25.  
  26. (defun ltof(fg / oer wlist x ss ssl n en sn sn1 sn2 idx one ename elayer p1 p2 p3 p4 p5 p6 sp ep sp1 ep1 sp2 ep2 p00 p01 p02 p03 p04 p05 p06 p07 p08 p09 p10 p11 p12 p13 p14 p15 p16 p17 p18 p19 wlength wwidth whight wthick wangle spl oldc)
  27.    (setvar "cmdecho" 0)
  28.    (setvar "elevation" 0)
  29.    (setvar "thickness" 0)
  30.    (setq surtab (getvar "surftab1"))
  31.    (setq oer *error* *error* ltoferr)
  32.    (command "color" "bylayer")
  33.    (princ "\nā–“Ļ€ā••ā–€ <")
  34.    (princ el)
  35.    (setq x (getint ">:"))
  36.    (if (/= x nil) (setq el x))
  37.    (setq ss (ssget))
  38.    (if ss (progn
  39.        (ltof0)
  40.        (ltof1)
  41.        (command "layer" "s" "0" "")
  42.    ))
  43.       (setvar "surftab1" surtab)
  44.       (setvar "cmdecho" 1)
  45.       (setq *error* oer)
  46.       (princ)
  47. )
  48.  
  49. (defun ltof0()
  50.    (command "layer" "n" "twindow" "c" 14 "twindow" "")
  51.    (command "layer" "n" "tdoor" "c" 5 "tdoor" "")
  52.    (command "layer" "m" "twall" "")
  53.    (setq ssl (sslength ss) n 0 pl nil ql nil baselv (getvar "elevation"))
  54.    (repeat ssl
  55.       (setq en (entget (setq sn (ssname ss n))))
  56.       (setq ename (cdr (assoc 0 en)) elayer (cdr (assoc 8 en)))
  57.       (if (and (= "INSERT" ename) (= "PWINDOW" elayer)) (progn
  58.           (setq sn1 (entnext sn) idx (cdr (assoc 1 (entget sn1))))
  59.           (strdv idx) (setq one wlist)
  60.           (setq insp (cdr (assoc 10 en)) wangle (cdr (assoc 50 en)))
  61.           (setq insz (cdr (assoc 43 en)) bn (cdr (assoc 2 en)))
  62.           (if (= (substr idx (strlen idx) 1) "@") (setq belv (atof (last one))) (setq belv 0))
  63.           (if (= (substr idx (strlen idx) 1) "$") (setq zz nil) (setq zz t))
  64.           (setq wlength (atoi (nth 1 one)))
  65.           (setq wwidth (atoi (nth 2 one)))
  66.           (setq whight (atoi (nth 3 one)))
  67.           (setq wthick (atoi (nth 4 one)))
  68.    (if (/= "CCA" (substr bn 1 3)) (progn
  69.    (if (= "CCZ" (substr bn 1 3)) (progn
  70. ;         (setq insz -1.0 belv 0)
  71.          (setq sn2 (entnext sn1) idx (cdr (assoc 1 (entget sn2))))
  72.          (strdv idx) (setq one wlist)
  73.          (setq p5 (list (atof (nth 1 one)) (atof (nth 2 one)) 0.0) p6 (list (atof (nth 7 one)) (atof (nth 8 one)) 0.0))
  74.          (setq p3 (list (atof (nth 3 one)) (atof (nth 4 one)) 0.0) p4 (list (atof (nth 5 one)) (atof (nth 6 one)) 0.0))
  75.          (setq p1 (polar p5 (angle p5 p3) (/ (distance p5 p3) 2.0)))
  76.          (setq p2 (polar p6 (angle p6 p4) (/ (distance p6 p4) 2.0)))
  77.          )(progn
  78.           (setq p1 (polar insp (+ pi wangle) (/ wlength 2)))
  79.           (setq p2 (polar insp wangle (/ wlength 2)))
  80.           (setq p3 (polar p1 (- wangle 1.57079) (/ wthick 2)))
  81.           (setq p4 (polar p2 (- wangle 1.57079) (/ wthick 2)))
  82.           (setq p5 (polar p1 (+ wangle 1.57079) (/ wthick 2)))
  83.           (setq p6 (polar p2 (+ wangle 1.57079) (/ wthick 2)))
  84.           )) ;endif "CZ"
  85.           (setq pl (cons (mapcar 'fix (list (car p3) (cadr p3))) pl) pl (cons (mapcar 'fix (list (car p4) (cadr p4))) pl))
  86.           (if (= fg "DUBBLE")
  87.           (setq pl (cons (mapcar 'fix (list (car p5) (cadr p5))) pl) pl (cons (mapcar 'fix (list (car p6) (cadr p6))) pl))
  88.           (setq ql (cons (mapcar 'fix (list (car p5) (cadr p5))) ql) ql (cons (mapcar 'fix (list (car p6) (cadr p6))) ql))
  89.           ) );endif "DUBBLE" endif "/= CA"
  90.           (progn
  91. ;         (setq insz -1.0 belv 0)
  92.           (setq sn2 (entnext sn1) idx (cdr (assoc 1 (entget sn2))))
  93.           (strdv idx) (setq one wlist)
  94.           (setq r1 (atof (nth 3 one)) r2 (atof (nth 4 one)) r (+ r2 (/ (- r1 r2) 2.0)))
  95.           (setq sa1 (atof (nth 1 one)) ea1 (atof (nth 2 one)) ma1 (- ea1 sa1))
  96.           (if (< ma1 0) (setq rl (* 2 pi r (/ (+ (* 2 pi) ma1) (* 2 pi)))) (setq rl (* 2 pi r (/ ma1 (* 2 pi)))))
  97.           (if (< ma1 0) (setq ma1 (+ sa1 (/ (+ (* 2 pi) ma1) 2.0))) (setq ma1 (+ sa1 (/ ma1 2.0))))
  98.           (setq cenp (polar insp (+ ma1 pi) (+ r2 (/ wthick 2.0))) cenp (list (car cenp) (cadr cenp) (+ baselv belv)))
  99.           (setq cenp1 (list (car cenp) (cadr cenp) (+ baselv whight) ) cenp2 (list (car cenp) (cadr cenp) (+ baselv whight wwidth)) cenp3 (list (car cenp) (cadr cenp) (+ baselv el)))
  100.           (setq p5 (polar cenp sa1 r2) p3 (polar cenp sa1 r1))
  101.           (setq p6 (polar cenp ea1 r2) p4 (polar cenp ea1 r1))
  102.           (setq p1 (polar cenp sa1 r) p2 (polar cenp ea1 r))
  103.           )) ;endif "/= CA"
  104.           (setq p00 (list (car p3) (cadr p3) (+ baselv belv)) p01 (list (car p4) (cadr p4) (+ baselv belv)))
  105.           (setq p02 (list (car p3) (cadr p3) (+ baselv whight)) p03 (list (car p4) (cadr p4) (+ baselv whight)))
  106.           (setq p04 (list (car p1) (cadr p1) (+ baselv whight)) p05 (list (car p2) (cadr p2) (+ baselv whight)))
  107.           (setq p06 (list (car p1) (cadr p1) (+ baselv whight wwidth)) p07 (list (car p2) (cadr p2) (+ baselv whight wwidth)))
  108.           (setq p08 (list (car p3) (cadr p3) (+ baselv whight wwidth)) p09 (list (car p4) (cadr p4) (+ baselv whight wwidth)))
  109.           (setq p10 (list (car p3) (cadr p3) (+ baselv el)) p11 (list (car p4) (cadr p4) (+ baselv el)))
  110.           (setq p12 (list (car p5) (cadr p5) (+ baselv belv)) p13 (list (car p6) (cadr p6) (+ baselv belv)))
  111.           (setq p14 (list (car p5) (cadr p5) (+ baselv whight)) p15 (list (car p6) (cadr p6) (+ baselv whight)))
  112.           (setq p16 (list (car p5) (cadr p5) (+ baselv whight wwidth)) p17 (list (car p6) (cadr p6) (+ baselv whight wwidth)))
  113.           (setq p18 (list (car p5) (cadr p5) (+ baselv el)) p19 (list (car p6) (cadr p6) (+ baselv el)))
  114.           (if (/= "CCA" (substr bn 1 3)) (progn
  115.           (if (> whight 0) (progn
  116.            (if (or (= fsh "All") (= fsh "Down")) (command "3dface" p00 "i" p01 "i" p03 "i" p02 "") (command "3dface" "i" p00 "i" p01 "i" p03 "i" p02 ""))
  117.            (if (= fg "DUBBLE")
  118.            (if (or (= fsh "All") (= fsh "Down")) (command "3dface" p12 "i" p13 "i" p15 "i" p14 "") (command "3dface" "i" p12 "i" p13 "i" p15 "i" p14 ""))
  119.            )
  120.                            (command "3dface" p02 "i" p03 p15 p14 "")
  121.           ))
  122.           (if (= (substr bn 1 2) "CC")(command "layer" "s" "twindow" "")(command "layer" "s" "tdoor" ""))
  123.           (command "3dface" p04 p05 p07 p06 "")
  124.           (command "layer" "s" "twall" "")
  125.           (command "3dface" p02 p14 p16 p08 "")
  126.           (command "3dface" p03 p15 "i" p17 p09 "")
  127.           (command "3dface" p08 p09 p17 "i" p16 "")
  128.           (if (and zz (not (equal (- el wwidth whight) 0))) (if (or (= fsh "All") (= fsh "Top")) (command "3dface" "i" p08 "i" p09 p11 "i" p10 "") (command "3dface" "i" p08 "i" p09 "i" p11 "i" p10 "")))
  129.            (if (= fg "DUBBLE")
  130.           (if (and zz (not (equal (- el wwidth whight) 0))) (if (or (= fsh "All") (= fsh "Top")) (command "3dface" "i" p16 "i" p17 p19 "i" p18 "") (command "3dface" "i" p16 "i" p17 "i" p19 "i" p18 "")))
  131.            ) ) ;endif "DUBBLE" endif "/=CA"
  132.            (progn
  133.            (if (> whight 0) (progn
  134.            (command "arc" p00 "c" cenp p01)
  135.            (setq sn1 (entlast))
  136.            (command "arc" p02 "c" cenp1 p03)
  137.            (setq sn2 (entlast))
  138.           (command "rulesurf" (list sn1 p00) (list sn2 p02))
  139.           (entdel sn1)
  140.           (command "arc" p14 "c" cenp1 p15)
  141.           (setq sn3 (entlast))
  142.           (command "rulesurf" (list sn3 p14) (list sn2 p02))
  143.           (entdel sn2)))
  144.           (command "arc" p16 "c" cenp2 p17)
  145.           (setq sn2 (entlast))
  146.           (command "arc" p08 "c" cenp2 p09)
  147.           (setq sn1 (entlast))
  148.           (command "rulesurf" (list sn2 p16) (list sn1 p08))
  149.           (command "arc" p10 "c" cenp3 p11)
  150.           (setq sn4 (entlast))
  151.           (if (and zz (not (equal (- el wwidth whight) 0))) (command "rulesurf" (list sn1 p08) (list sn4 p10)))
  152.           (entdel sn1) (entdel sn4)
  153.           (command "3dface" p03 p15 p17 p09 "")
  154.           (command "3dface" p02 p14 p16 p08 "")
  155.           (if (= fg "DUBBLE") (progn
  156.           (if (> whight 0) (progn
  157.           (command "arc" p12 "c" cenp p13)
  158.           (setq sn1 (entlast))
  159.           (command "rulesurf" (list sn1 p12) (list sn3 p14))
  160.           (entdel sn1) (entdel sn3) ))
  161.           (command "arc" p18 "c" cenp3 p19)
  162.           (setq sn4 (entlast))
  163.           (if (and zz (not (equal (- el wwidth whight) 0))) (command "rulesurf" (list sn2 p16) (list sn4 p18)))
  164.           (entdel sn2) (entdel sn4)
  165.           ) (entdel sn2))
  166.           (command "layer" "s" "twindow" "")
  167.           (setq nn (fix (/ rl 600.0)))
  168.           (if (<= nn 2) (command "3dface" p04 p05 p07 p06 "") (progn
  169.           (setvar "surftab1" nn)
  170.           (command "arc" p04 "c" cenp1 p05)
  171.           (setq sn1 (entlast))
  172.           (command "arc" p06 "c" cenp2 p07)
  173.           (setq sn2 (entlast))
  174.           (command "rulesurf" (list sn1 p04) (list sn2 p06))
  175.           (command "explode" (entlast))
  176.           (setvar "surftab1" surtab)
  177.           (entdel sn1) (entdel sn2)
  178.            )) ;endif nn
  179.            (command "layer" "s" "twall" "")
  180.            )) ;endif "/=CA"
  181.           )) ;endif
  182.           (setq n (1+ n))
  183.        )
  184. )
  185.  
  186. (defun ltof1()
  187.        (setq n 0 spl nil)
  188.        (repeat ssl
  189.            (setq en (entget (setq sn (ssname ss n))))
  190.            (setq ename (cdr (assoc 0 en)) elayer (cdr (assoc 8 en)))
  191.            (if (and (= "LINE" ename) (= "PWALL" (substr elayer 1 5))) (progn
  192.            (setq sp (cdr (assoc 10 en)) ep (cdr (assoc 11 en)))
  193.            (setq sp2 (mapcar 'fix (list (car sp) (cadr sp))) ep2 (mapcar 'fix (list (car ep) (cadr ep))))
  194.            (setq sp1 (list (car sp) (cadr sp) (+ baselv el)) ep1 (list (car ep) (cadr ep) (+ baselv el)))
  195.            (cond ((and (member sp2 pl) (member ep2 pl))
  196.               (cond ((= fsh "All") (command "3dface" sp "i" ep ep1 "i" sp1 ""))
  197.                     ((= fsh "Down") (command "3dface" sp "i" ep "i" ep1 "i" sp1 ""))
  198.                     ((= fsh "Top") (command "3dface" "i" sp "i" ep ep1 "i" sp1 ""))
  199.                     (t (command "3dface" "i" sp "i" ep "i" ep1 "i" sp1 ""))))
  200.                  ((member sp2 pl)
  201.                    (cond ((= fsh "All") (command "3dface" sp ep ep1 "i" sp1 ""))
  202.                          ((= fsh "Down") (command "3dface" sp ep "i" ep1 "i" sp1 ""))
  203.                          ((= fsh "Top") (command "3dface" "i" sp ep ep1 "i" sp1 ""))
  204.                          (t (command "3dface" "i" sp ep "i" ep1 "i" sp1 ""))))
  205.                  ((member ep2 pl)
  206.                    (cond ((= fsh "All") (command "3dface" sp "i" ep ep1 sp1 ""))
  207.                          ((= fsh "Down") (command "3dface" sp "i" ep "i" ep1 sp1 ""))
  208.                          ((= fsh "Top") (command "3dface" "i" sp "i" ep ep1 sp1 ""))
  209.                          (t (command "3dface" "i" sp "i" ep "i" ep1 sp1 ""))))
  210.                  (t (if (or (= fg "DUBBLE") (not (or (member sp2 ql) (member ep2 ql))))
  211.                     (cond ((= fsh "All") (command "3dface" sp ep ep1 sp1 ""))
  212.                           ((= fsh "Down") (command "3dface" sp ep "i" ep1 sp1 ""))
  213.                           ((= fsh "Top") (command "3dface" "i" sp ep ep1 sp1 ""))
  214.                           (t (command "3dface" "i" sp ep "i" ep1 sp1 "")))))
  215.            )
  216.            ) (if (and (= "ARC" ename) (= "PWALL" (substr elayer 1 5))) (progn
  217.            (setq insp (cdr (assoc 10 en)) sa1 (cdr (assoc 50 en)) ea1 (cdr (assoc 51 en)) r (cdr (assoc 40 en)) ma1 (- ea1 sa1))
  218.            (if (< ma1 0) (setq rl (* 2 pi r (/ (+ (* 2 pi) ma1) (* 2 pi)))) (setq rl (* 2 pi r (/ ma1 (* 2 pi)))))
  219.            (setq nn (/ rl (getvar "userr4")))
  220.            (if (< nn 2) (setq nn 2)) (setvar "surftab1" nn)
  221.            (setq p1 (polar insp sa1 r) p2 (polar insp ea1 r))
  222.            (setq cenp (list (car insp) (cadr insp) (+ (caddr insp) el)))
  223.            (setq p3 (list (car p1) (cadr p1) (+ (caddr p1) el)))
  224.            (setq p4 (list (car p2) (cadr p2) (+ (caddr p2) el)))
  225.            (command "arc" p3 "c" cenp p4)
  226.            (setq sn1 (entlast))
  227.            (command "rulesurf" (list sn p1) (list sn1 p3))
  228.           ))) ;endif
  229.            (setq n (1+ n))
  230.        )
  231. )
  232.  
  233. (defun strdv(rn / loop l x)
  234.        (setq wlist nil loop t)
  235.        (while loop
  236.           (setq l (instr 1 rn " "))
  237.           (if (= l 0) (setq wlist (cons rn wlist) loop nil)
  238.              (progn ;else
  239.              (setq x (substr rn 1 (1- l)))
  240.              (setq wlist (cons x wlist))
  241.              (setq rn (substr rn (1+ l) (- (strlen rn) l)))
  242.              (setq loop t)
  243.              )
  244.           )
  245.        )
  246.        (setq wlist (reverse wlist))
  247. )
  248.  
  249. (defun instr(st s0 s00 / l n loop x n0 l0)
  250.    (setq l (+ (- (strlen s0) st) 1) l0 0 n0 st n 1 loop t)
  251.    (while (and (<= n l) loop)
  252.       (setq x (substr s0 n0 1))
  253.       (if (eq x s00) (setq loop nil l0 n0) (setq n0 (1+ n0) n (1+ n)))
  254.    )
  255.    (eval l0)
  256. )
  257.