home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / TJ.LSP < prev    next >
Encoding:
Text File  |  1992-02-28  |  8.3 KB  |  178 lines
  1. (vmon)
  2.  
  3. (defun tjerr(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. (defun C:TJ(/ oer terh s1 tw tw1 tw2 tw0 tl1 tl2 axdl x p ang)
  14.    (setvar "cmdecho" 0)
  15.    (setq elv (getvar "elevation"))
  16.    (setq oer *error* *error* tjerr)
  17.    (setq s1 (getstring "\n╩Σ╚δ╠¿╜╫╩╜╤∙3/2/1/<0>:"))
  18.    (if (= s1 "") (setq s1 "0"))
  19.    (if (and (>= s1 "0") (<= s1 "3")) (progn
  20.    (cond ((= s1 "0") (setq tl1 (getint "\n╩Σ╚δ╞┬╡└│ñ╢╚ <3600>:"))
  21.                      (if (= tl1 nil) (setq tl1 3600))
  22.                      (setq tw (getint "\n╩Σ╚δ╞┬╡└┐φ╢╚ <1200>:"))
  23.                      (if (= tw nil) (setq tw 1200))
  24.                      (setq tw1 (getint "\n╩Σ╚δ╞┬╡└╖┼╞┬╛α└δ <600>:"))
  25.                      (if (= tw1 nil) (setq tw1 600)))
  26.          ((= s1 "1") (setq tl1 (getint "\n╩Σ╚δ╠¿╜╫│ñ╢╚ <3600>:"))
  27.                      (if (= tl1 nil) (setq tl1 3600))
  28.                      (setq tw (getint "\n╩Σ╚δ╠¿╜╫┐φ╢╚ <1200>:"))
  29.                      (if (= tw nil) (setq tw 1200))
  30.                      (setq tw1 (getint "\n╩Σ╚δ╠ñ▓╜┐φ <200>:"))
  31.                      (if (= tw1 nil) (setq tw1 200))
  32.                      (setq tw2 (getint "\n╩Σ╚δ╠ñ▓╜╕÷╩² <3>:"))
  33.                      (if (= tw2 nil) (setq tw2 3)))
  34.          ((= s1 "2") (setq tl1 (getint "\n╩Σ╚δ╠¿╜╫│ñ╢╚ <3600>:"))
  35.                      (if (= tl1 nil) (setq tl1 3600))
  36.                      (setq tw (getint "\n╩Σ╚δ╠¿╜╫┐φ╢╚ <1200>:"))
  37.                      (if (= tw nil) (setq tw 1200))
  38.                      (setq tw1 (getint "\n╩Σ╚δ╠ñ▓╜┐φ╢╚ <200>:"))
  39.                      (if (= tw1 nil) (setq tw1 200))
  40.                      (setq tw2 (getint "\n╩Σ╚δ╠ñ▓╜╕÷╩² <3>:"))
  41.                      (if (= tw2 nil) (setq tw2 3)))
  42.          ((= s1 "3") (setq tl1 (getint "\n╩Σ╚δ╠¿╜╫│ñ╢╚ <3600>:"))
  43.                      (if (= tl1 nil) (setq tl1 3600))
  44.                      (setq tw (getint "\n╩Σ╚δ╠¿╜╫┐φ╢╚ <1200>:"))
  45.                      (if (= tw nil) (setq tw 1200))
  46.                      (setq tw1 (getint "\n╩Σ╚δ╠ñ▓╜┐φ <200>:"))
  47.                      (if (= tw1 nil) (setq tw1 200))
  48.                      (setq tw2 (getint "\n╩Σ╚δ╠ñ▓╜╕÷╩² <3>:"))
  49.                      (if (= tw2 nil) (setq tw2 3)))
  50.     )
  51.    (setq terh (getint "\n╩Σ╚δ╠ñ▓╜╕▀╢╚ <150>:"))
  52.    (if (= terh nil) (setq terh 150))
  53.    (graphscr)
  54.    (initget "R")
  55.    (setq p (getpoint "\n▓╬┐╝╡πR/<▓σ╚δ╓╨╡π>:"))
  56.    (if (= p "R") (progn (setq p (getpoint "\n▓╬┐╝╡π:"))
  57.                  (setq p (getpoint p "\n▓σ╚δ╓╨╡π:"))))
  58.    (setq ang (getangle p "\n▓σ╚δ╖╜╧≥ <0>:"))
  59.    (if (= ang nil) (setq ang 0))
  60.    (setq p (polar p (+ ang pi) (/ tl1 2.0)))
  61.    (setvar "thickness" terh)
  62.    (command "layer" "m" "tother" "")
  63.    (cond ((= s1 "0") (tj1 tl1 tw tw1 p ang))
  64.          ((= s1 "1") (tj2 tl1 tw tw1 tw2 p ang))
  65.          ((= s1 "2") (tj3 tl1 tw tw1 tw2 p ang))
  66.          ((= s1 "3") (tj4 tl1 tw tw1 tw2 p ang))
  67.    )
  68.    ))
  69.    (command "layer" "s" "0" "")
  70.    (setvar "thickness" 0)
  71.    (setvar "elevation" elv)
  72.    (setvar "cmdecho" 1)
  73.    (setq *error* oer)
  74.    (princ)
  75. )
  76.  
  77. (defun tj1(tl11 tw1 tw11 p1 ang1 / p2 p3 p4 p5 p6 sn)
  78.                       (setq el (- elv terh))
  79.                       (setq p1 (list (car p1) (cadr p1) el))
  80.                       (setq p2 (polar p1 (- ang1 1.57079) tw1))
  81.                       (setq p3 (polar p2 ang1 tl11))
  82.                       (setq p4 (polar p3 (+ ang1 1.57079) tw1))
  83.                       (setvar "thickness" 0)
  84.                       (command "pline" p1 "w" 0 "" p2 p3 p4 "")
  85.                       (setq p5 (polar p1 ang1 tw11) p5 (list (car p5) (cadr p5) elv))
  86.                       (setq p6 (polar p4 (+ ang1 pi) tw11) p6 (list (car p6) (cadr p6) elv))
  87.                       (command "3dface" "i" p1 "i" p2 p5 "" "")
  88.                       (command "3dface" "i" p4 "i" p3 p6 "" "")
  89.                       (command "3dface" p5 "i" p2 p3 p6 "")
  90. )
  91.  
  92. (defun tj2(tl11 tw1 tw11 tw22 p1 ang1 / plw ang0 ang2 p2 p3 p4 p5 pl l n sn sn1)
  93.    (setq el (- elv (* tw22 terh)) p0 p1)
  94.    (setq ang0 (- ang1 1.57079) ang2 (+ ang1 1.57079))
  95.    (setq p1 (list (car p1) (cadr p1) el))
  96.    (setq p2 (polar p1 ang0 tw1) p3 (polar p2 ang tl11) p4 (polar p3 ang2 tw1))
  97.    (command "pline" p1 "w" "0" "" p2 p3 p4 "")
  98.    (setq sn (entlast) l (1- tw22))
  99.    (command "3dface" "i" p1 "i" p2 "i" p3 p4 "")
  100.    (setq el (- elv (* terh l)))
  101.    (command "move" (entlast) "" p1 (list (car p1) (cadr p1) (+ (last p1) terh)))
  102.    (repeat l
  103.       (setq el (- elv (* terh (setq tw22 (1- tw22)))))
  104.       (setq p2 (polar p1 ang1 50))
  105.       (command "offset" tw11 (list sn p1) p2 "")
  106.       (command "move" (setq sn (ssget "L")) "" p1 (list (car p1) (cadr p1) (+ (last p1) terh)))
  107.       (setq sn (ssname sn 0))
  108.       (setq p1 (cdr (assoc 10 (entget (setq sn1 (entnext sn))))))
  109.       (setq p2 (cdr (assoc 10 (entget (setq sn1 (entnext sn1))))))
  110.       (setq p3 (cdr (assoc 10 (entget (setq sn1 (entnext sn1))))))
  111.       (setq p4 (cdr (assoc 10 (entget (entnext sn1)))))
  112.       (setq p1 (list (car p1) (cadr p1) (+ (last p1) terh)))
  113.       (setq p2 (list (car p2) (cadr p2) (+ (last p2) terh)))
  114.       (setq p3 (list (car p3) (cadr p3) (+ (last p3) terh)))
  115.       (setq p4 (list (car p4) (cadr p4) (+ (last p4) terh)))
  116.       (command "3dface" "i" p1 "i" p2 "i" p3 p4 "")
  117.    )
  118. )
  119.  
  120. (defun tj3(tl11 tw1 tw11 tw22 p1 ang1 / plw ang0 ang2 p2 p3 p4 p5 pl l n sn sn1 dist)
  121.    (setq el (- elv (* tw22 terh)))
  122.    (setq ang0 (- ang1 1.57079) ang2 (+ ang1 1.57079))
  123.    (setq p1 (list (car p1) (cadr p1) el))
  124.    (setq p2 (polar p1 ang0 tw1) p3 (polar p2 ang tl11) p4 (polar p3 ang2 tw1))
  125.    (command "pline" p2 "w" "0" "" p3 "")
  126.    (setq sn (entlast) l tw22 n 0)
  127.    (setq p4 (polar p2 ang2 tw11) p5 (polar p3 ang2 tw11))
  128.    (command "3dface" "i" p2 p3 "i" p5 p4 "")
  129.    (command "move" (entlast) "" p2 (list (car p2) (cadr p2) (- elv (* terh (1- tw22)))))
  130.    (repeat l
  131.       (setq el (- elv (* terh (setq tw22 (1- tw22)))))
  132.       (setq p2 (polar p1 ang2 50))
  133.       (if (< n (1- l)) (command "offset" tw11 (list sn p1) p2 "") (command "offset" (- tw1 (* (- l 1) tw11)) (list sn p1) p2 ""))
  134.       (if (< n (1- l)) (command "move" (setq sn (ssget "L")) "" p1 (list (car p1) (cadr p1) (+ (last p1) terh)) )(progn (command "move" (setq sn (ssget "L")) "" p1 (list (car p1) (cadr p1) (+ (last p1) terh))) (command "change" sn "" "p" "t" 0 "")))
  135.       (setq sn (ssname sn 0))
  136.       (if (< n (1- l)) (progn
  137.       (if (= n (- l 2)) (setq dist (- tw1 (* (- l 1) tw11))) (setq dist tw11))
  138.       (setq p1 (cdr (assoc 10 (entget (setq sn1 (entnext sn))))))
  139.       (setq p2 (cdr (assoc 10 (entget (entnext sn1)))))
  140.       (setq p3 (polar p1 ang2 dist) p4 (polar p2 ang2 dist))
  141.       (setq p1 (list (car p1) (cadr p1) (+ (last p1) terh)))
  142.       (setq p2 (list (car p2) (cadr p2) (+ (last p2) terh)))
  143.       (setq p3 (list (car p3) (cadr p3) (+ (last p3) terh)))
  144.       (setq p4 (list (car p4) (cadr p4) (+ (last p4) terh)))
  145.       (command "3dface" "i" p1 p2 "i" p4 p3 ""))) ;if
  146.       (setq n (1+ n))
  147.    )
  148. )
  149.  
  150. (defun tj4(tl11 tw1 tw11 tw22 p1 ang1 / plw ang0 ang2 p2 p3 p4 p5 pl l n sn sn1)
  151.    (setq el (- elv (* tw22 terh)))
  152.    (setq ang0 (- ang1 1.57079) ang2 (+ ang1 1.57079))
  153.    (setq p1 (list (car p1) (cadr p1) el))
  154.    (setq p2 (polar p1 ang0 tw1) p3 (polar p2 ang tl11) p4 (polar p3 ang2 tw1))
  155.    (command "pline" p1 "w" "0" "" p2 p3 "")
  156.    (setq sn (entlast) l (1- tw22) n 1)
  157.    (setq p4 (polar p3 ang2 tw1))
  158.    (command "3dface" "i" p1 "i" p2 p3 p4 "")
  159.    (command "move" (entlast) "" p1 (list (car p1) (cadr p1) (- elv (* terh l)) ))
  160.    (repeat l
  161.       (setq el (- elv (* terh (setq tw22 (1- tw22)))))
  162.       (setq p2 (polar p1 ang1 50))
  163.       (command "offset" tw11 (list sn p1) p2 "")
  164.       (command "move" (setq sn (ssget "L")) "" p1 (list (car p1) (cadr p1) (+ (last p1) terh)))
  165.       (setq sn (ssname sn 0))
  166.       (setq p1 (cdr (assoc 10 (entget (setq sn1 (entnext sn))))))
  167.       (setq p2 (cdr (assoc 10 (entget (setq sn1 (entnext sn1))))))
  168.       (setq p3 (cdr (assoc 10 (entget (entnext sn1)))))
  169.       (setq p4 (polar p3 ang2 (- tw1 (* n tw11))))
  170.       (setq p1 (list (car p1) (cadr p1) (+ (last p1) terh)))
  171.       (setq p2 (list (car p2) (cadr p2) (+ (last p2) terh)))
  172.       (setq p3 (list (car p3) (cadr p3) (+ (last p3) terh)))
  173.       (setq p4 (list (car p4) (cadr p4) (+ (last p4) terh)))
  174.       (command "3dface" "i" p1 "i" p2 p3 p4 "")
  175.       (setq n (1+ n))
  176.    )
  177. )
  178.