home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / TER.LSP < prev    next >
Encoding:
Text File  |  1992-01-31  |  7.0 KB  |  208 lines
  1. (vmon)
  2.  
  3. (defun terr(s)
  4.    (if (/= s "Function cancelled")
  5.        (princ (strcat "\nError:" s))
  6.    )
  7.    (command "layer" "s" "0" "")
  8.    (setvar "cmdecho" 1)
  9.    (setvar "thickness" 0)
  10.    (setvar "elevation" elv)
  11.    (setq *error* oer)
  12.    (princ)
  13. )
  14.  
  15. (defun C:TER(/ oer tert terh s1 tw tw0 tl1 tl2 axdl x p ang el elv)
  16.    (setvar "cmdecho" 0)
  17.    (setq elv (getvar "elevation"))
  18.    (setvar "elevation" 0)
  19.    (setq oer *error* *error* terr)
  20.    (setq s1 (getstring "\n╩Σ╚δ╤⌠╠¿╩╜╤∙4/3/2/<1>:"))
  21.    (if (= s1 "") (setq s1 "1"))
  22.    (if (and (>= s1 "1") (<= s1 "4")) (progn
  23.    (cond ((= s1 "1") (setq tw 1200 tl1 (getint "\n╩Σ╚δ╤⌠╠¿│ñ╢╚ <3600>:"))
  24.                      (if (= tl1 nil) (setq tl1 3600)))
  25.          ((= s1 "2") (setq tw 1200 tl1 (getstring "\n╩Σ╚δ╕≈╤⌠╠¿│ñ╢╚ <3600,3600>:"))
  26.                      (if (= tl1 "") (setq tl1 "3600,3600"))
  27.                      (sub1 tl1)
  28.                      (setq tl1 axdl))
  29.          ((= s1 "3") (setq tw 1200 tl1 (getint "\n╩Σ╚δ╤⌠╠¿│ñ╢╚ <3600>:"))
  30.                      (if (= tl1 nil) (setq tl1 3600)))
  31.          ((= s1 "4") (setq tw 2100 tl1 (getint "\n╩Σ╚δ╤⌠╠¿╟░│ñ╢╚ <3600>:"))
  32.                      (if (= tl1 nil) (setq tl1 3600))
  33.                      (setq tl2 (getint "\n╩Σ╚δ╤⌠╠¿║≤│ñ╢╚ <1100>:"))
  34.                      (if (= tl2 nil) (setq tl2 1100))
  35.                      (setq tw0 (getint "\n╩Σ╚δ╤⌠╠¿╒²├µ┐φ╢╚ <1200>:"))
  36.                      (if (= tw0 nil) (setq tw0 1200)))
  37.     )
  38.    (princ "\n╩Σ╚δ╤⌠╠¿┐φ╢╚ <")
  39.    (princ tw)
  40.    (setq x (getint ">:"))
  41.    (if (/= x nil) (setq tw x))
  42.    (setq terh (getint "\n╤⌠╠¿╕▀╢╚ <1100>:"))
  43.    (if (= terh nil) (setq terh 1100))
  44.    (setq tert (getint "\n╤⌠╠¿└╕░σ║± <120> :"))
  45.    (if (= tert nil) (setq tert 120))
  46.    (graphscr)
  47.    (initget "R")
  48.    (setq p (getpoint "\n▓╬┐╝╡πR/<▓σ╚δ╡π>:"))
  49.    (if (= p "R") (progn (setq p (getpoint "\n▓╬┐╝╡π:"))
  50.                  (setq p (getpoint p "\n▓σ╚δ╡π:"))))
  51.    (setq ang (getangle p "\n▓σ╚δ╖╜╧≥ <0>:"))
  52.    (if (= ang nil) (setq ang 0))
  53.    (setvar "thickness" terh)
  54.    (command "layer" "m" "terrace" "")
  55.    (setq p (list (car p) (cadr p) -150))
  56.    (cond ((= s1 "1") (ter1 tl1 tw p ang))
  57.          ((= s1 "2") (ter2 tl1 tw p ang))
  58.          ((= s1 "3") (ter3 tl1 tw p ang))
  59.          ((= s1 "4") (ter4 tl1 tl2 tw0 tw p ang))
  60.    )
  61.    ))
  62.    (command "layer" "s" "0" "")
  63.    (setvar "thickness" 0)
  64.    (setvar "elevation" elv)
  65.    (setvar "cmdecho" 1)
  66.    (setq *error* oer)
  67.    (princ)
  68. )
  69.  
  70. (defun ter1(tl11 tw1 p1 ang1 / p2 p3 p4 sn)
  71.                       (setq p2 (polar p1 (- ang1 1.57079) tw1))
  72.                       (setq p3 (polar p2 ang1 tl11))
  73.                       (setq p4 (polar p3 (+ ang1 1.57079) tw1))
  74.                       (command "pline" p1 "w" 0 "" p2 p3 p4 "")
  75.                       (setq sn (entlast))
  76.                       (command "3dface" p1 p2 p3 p4 "")
  77.                       (setq p3 (polar p1 ang1 tert))
  78.                       (command "offset" "t" (list sn p1) p3 "")
  79.                       (command "pedit" sn "w" "0" "")
  80. )
  81.  
  82. (defun ter2(tl11 tw1 p1 ang1 / plw ang0 ang2 p2 p3 p4 p5 pl l n)
  83.    (setq plw tert)
  84.    (setq ang0 (- ang1 1.57079) ang2 (+ ang1 1.57079))
  85.    (setq p2 (polar p1 ang0 tw1) p3 (polar p2 ang (apply '+ tl11)) p4 (polar p3 ang2 tw1))
  86.    (command "pline" p1 "w" 0 "" p2 p3 p4 "")
  87.    (command "3dface" p1 p2 p3 p4 "")
  88.    (setq n 0 pl nil)
  89.    (repeat (setq l (length tl11))
  90.       (setq p2 (polar p1 ang1 plw) pl (cons p2 pl))
  91.       (setq p3 (polar p2 ang0 (- tw1 plw)) pl (cons p3 pl))
  92.       (if (or (= n 0) (= n (1- l))) (setq p4 (polar p3 ang1 (- (nth n tl11) (* 1.5 plw)))) (setq p4 (polar p3 ang1 (- (nth n tl11) plw))))
  93.       (setq pl (cons p4 pl))
  94.       (setq p5 (polar p4 ang2 (- tw1 plw)) pl (cons p5 pl))
  95.       (setq n (1+ n) p1 p5)
  96.    )
  97.    (setq pl (reverse pl))
  98.    (command "pline" (nth 0 pl) "w" "0" "")
  99.    (setq n 1)
  100.    (repeat (1- (length pl))
  101.       (command (nth n pl))
  102.       (setq n (1+ n))
  103.    )
  104.    (command)
  105. )
  106.  
  107. (defun ter3(tl11 tw1 p1 ang1 / ss p2 p3 p4 plw kw)
  108.    (setq plw tert ss nil ss (ssadd))
  109.    (setq p2 (polar p1 (- ang1 1.57079) tw1))
  110.    (setq p3 (polar p2 ang1 tl11))
  111.    (setq p4 (polar p1 ang1 tl11))
  112.    (command "pline" p1 "w" 0 "" p2 p3 p4 "")
  113.    (ssadd (entlast) ss)
  114.    (command "3dface" p1 p2 p3 p4 "")
  115.    (ssadd (entlast) ss)
  116.    (setq p2 (polar p1 (- ang1 1.57079) (- tw1 plw)))
  117.    (setq p3 (polar p2 ang1 (- tl11 plw)))
  118.    (setq p4 (polar p1 ang1 (- tl11 plw)))
  119.    (command "pline" p2 "w" "0" "" p3 p4 "")
  120.    (ssadd (entlast) ss)
  121.    (initget "Yes No")
  122.    (setq kw (getkword "\n╡≈╒√╤⌠╠¿╬╗╓├ <N>:"))
  123.    (if (= kw "Yes") (progn
  124.    (setq p1 (getpoint "\n╩Σ╚δ╢╘│╞╓ß╡┌╥╗╡π:"))
  125.    (setq p2 (getpoint p1 "\n╩Σ╚δ╢╘│╞╓ß╡┌╢■╡π:"))
  126.    (command "mirror" ss "" p1 p2 "y")))
  127. )
  128.  
  129. (defun ter4(tl11 tl22 tw11 tw22 p1 ang1 / p2 p3 p4 p5 p6 plw kw ss)
  130.    (setq plw tert ss nil ss (ssadd))
  131.    (setq p2 (polar p1 (- ang1 1.57079) tw11))
  132.    (setq p3 (polar p2 ang1 tl11))
  133.    (setq p4 (polar p3 (+ ang1 1.57079) tw22))
  134.    (setq p5 (polar p4 (+ ang1 pi) tl22))
  135.    (setq p6 (polar p1 ang1 (- tl11 tl22)))
  136.    (command "pline" p1 "w" 0 "" p2 p3 p4 p5 "")
  137.    (ssadd (entlast) ss)
  138.    (command "3dface" p1 p2 "i" p3 p6 "")
  139.    (ssadd (entlast) ss)
  140.    (command "3dface" "i" p6 p3 p4 p5 "")
  141.    (ssadd (entlast) ss)
  142.    (setq p1 (polar p1 ang1 plw))
  143.    (setq p2 (polar p1 (- ang1 1.57079) (- tw11 plw)))
  144.    (setq p3 (polar p2 ang1 (- tl11 (* 2 plw))))
  145.    (setq p4 (polar p3 (+ ang1 1.57079) (- tw22 (* 2 plw))))
  146.    (setq p5 (polar p4 (+ ang1 pi) (- tl22 plw)))
  147.    (command "pline" p1 "w" "0" "" p2 p3 p4 p5 "")
  148.    (ssadd (entlast) ss)
  149.    (initget "Yes No")
  150.    (setq kw (getkword "\n╡≈╒√╤⌠╠¿╬╗╓├ <N>:"))
  151.    (if (= kw "Yes") (progn
  152.    (setq p1 (getpoint "\n╩Σ╚δ╢╘│╞╓ß╡┌╥╗╡π:"))
  153.    (setq p2 (getpoint p1 "\n╩Σ╚δ╢╘│╞╓ß╡┌╢■╡π:"))
  154.    (command "mirror" ss "" p1 p2 "y")))
  155. )
  156.  
  157. (defun instr(st s0 s00 / l n loop x n0 l0)
  158.    (setq l (+ (- (strlen s0) st) 1) l0 0 n0 st n 1 loop t)
  159.    (while (and (<= n l) loop)
  160.       (setq x (substr s0 n0 1))
  161.       (if (eq x s00) (setq loop nil l0 n0) (setq n0 (1+ n0) n (1+ n)))
  162.    )
  163.    (eval l0)
  164. )
  165.  
  166.  
  167. (defun sub2(af / l0 sp ep)
  168.    (setq l0 (instr 1 af "*") nl nil)
  169.    (setq sp (substr af 1 (- l0 1)) ep (substr af (+ l0 1)))
  170.    (repeat (atoi sp)
  171.       (setq nl (cons (atof ep) nl))
  172.    )
  173. )
  174.  
  175. (defun sub1(axd / l0 l1 ax nl)
  176.    (setq axdl nil)
  177.    (if (and (= (instr 1 axd ",") 0) (> (strlen axd) 0))
  178.    (progn
  179.    (if (> (instr 1 axd "*") 0)
  180.        (progn
  181.        (sub2 axd)
  182.        (setq axdl nl))
  183.        (setq axdl (cons (atof axd) axdl))
  184.    )
  185.    )
  186.    (progn
  187.    (setq l0 0 l1 (instr 1 axd ","))
  188.    (while (> (instr (+ l0 1) axd ",") 0)
  189.      (setq ax (substr axd (+ l0 1) (- l1 l0 1)))
  190.      (if (> (instr 1 ax "*") 0) (progn
  191.      (sub1 ax)
  192.      (setq axdl (append nl axdl))
  193.      )
  194.      (setq axdl (cons (atof ax) axdl))
  195.      )
  196.      (setq l0 l1 l1 (instr (+ l0 1) axd ","))
  197.    )
  198.    (setq ax (substr axd (+ l0 1)))
  199.    (if (> (instr 1 ax "*") 0) (progn
  200.    (sub2 ax)
  201.    (setq axdl (append nl axdl))
  202.    )
  203.    (setq axdl (cons (atof ax) axdl))
  204.    )
  205.    ))
  206.    (setq axdl (reverse axdl))
  207. )
  208.