home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / PROJ.LSP < prev    next >
Encoding:
Text File  |  1992-01-29  |  3.4 KB  |  74 lines
  1. (vmon)
  2.  
  3. (defun projerr(s)
  4.    (if (/= s "Function cancelled")
  5.        (princ (strcat "\Error:" s))
  6.    )
  7.    (command "layer" "s" "0" "")
  8.    (setvar "cmdecho" 1)
  9.    (setvar "blipmode" 1)
  10.    (setvar "highlight" 1)
  11.    (setq *error* oer)
  12.    (princ)
  13. )
  14.       
  15. (setq fdist 45)
  16.  
  17. (defun C:PROJ(/ x en1 sn1 ename1 elay1 fg p0 p1 p2 p3 np1 np2 np3 np4 fd p4 p5 p00 p01 p02 p03 sn en)
  18.    (setvar "cmdecho" 0)
  19.    (setvar "blipmode" 0)
  20.    (setvar "highlight" 0)
  21.    (setq oer *error* *error* projerr)
  22.    (princ "\n╩Σ╚δ╔ó╔Σ╫┤┤░╡─╞┬╢╚ <")
  23.    (princ fdist)
  24.    (setq x (getreal ">:"))
  25.    (if (/= x nil) (setq fdist x))
  26.    (setq sn1 (car (entsel "\n╤í╘±╢┤┐┌╞╜├µ╗≥├┼┤░╞╜├µ:")))
  27.    (setq en1 (entget sn1) ename1 (cdr (assoc 0 en1)) elay1 (cdr (assoc 8 en1)))
  28.    (if (and (= ename1 "3DFACE") (= elay1 "TWALL")) (progn
  29.    (setq fg (cdr (assoc 70 en1)) p0 (cdr (assoc 10 en1)) p1 (cdr (assoc 11 en1)) p2 (cdr (assoc 12 en1)) p3 (cdr (assoc 13 en1)))
  30.    (cond ((or (= fg 2) (= fg 8))
  31.    (setq fd (/ (* (distance p0 p3) (sin (/ (* fdist pi) 180.0)))  (cos (/ (* fdist pi) 180.0))))
  32.    (setq np1 (polar p3 (angle p3 p2) fd) np2 (polar p2 (angle p2 p3) fd))
  33.    (if (= fg 2) (setq np1 (list (car np1) (cadr np1) (+ (caddr np1) fd)) np2 (list (car np2) (cadr np2) (+ (caddr np2) fd))) (setq np1 (list (car np1) (cadr np1) (- (caddr np1) fd)) np2 (list (car np2) (cadr np2) (- (caddr np2) fd))))
  34.    (setq en1 (subst (cons 13 np1) (assoc 13 en1) en1))
  35.    (entmod en1)
  36.    (setq en1 (subst (cons 12 np2) (assoc 12 en1) en1))
  37.    (entmod en1))
  38.    ((or (= fg 0) (= fg 4))
  39.    (setq fd (/ (* (distance p0 p1) (sin (/ (* fdist pi) 180.0))) (cos (/ (* fdist pi) 180.0))))
  40.    (if (= fg 0) (setq np1 (polar p1 (- (angle p0 p1) 1.57079) fd) np2 (polar p2 (- (angle p3 p2) 1.57079) fd)) (setq np1 (polar p1 (+ (angle p0 p1) 1.57079) fd) np2 (polar p2 (+ (angle p3 p2) 1.57079) fd)))
  41.    (setq np1 (list (car np1) (cadr np1) (+ (caddr np1) fd)) np2 (list (car np2) (cadr np2) (- (caddr np2) fd)))
  42.    (setq en1 (subst (cons 11 np1) (assoc 11 en1) en1))
  43.    (entmod en1)
  44.    (setq en1 (subst (cons 12 np2) (assoc 12 en1) en1))
  45.    (entmod en1)))
  46.    ) ;then
  47.    (if (and (= ename1 "3DFACE") (member elay1 '("TWINDOW" "TDOOR"))) (progn
  48.    (setq sn (car (entsel "\n╤í╘±╢┤┐┌╞╜├µ:")))
  49.    (setq en (entget sn) p0 (cdr (assoc 10 en)) p1 (cdr (assoc 11 en)) p2 (cdr (assoc 12 en)) p3 (cdr (assoc 13 en)))
  50.    (setq fg (cdr (assoc 70 en)))
  51.    (setq p00 (cdr (assoc 10 en1)) p01 (cdr (assoc 11 en1)) p02 (cdr (assoc 12 en1)) p03 (cdr (assoc 13 en1)))
  52.    (if (or (= fg 0) (= fg 4))
  53.    (setq fd (/ (* (distance p0 p1) (sin (/ (* pi fdist) 180.0))) 2.0))
  54.    (setq fd (/ (* (distance p1 p2) (sin (/ (* pi fdist) 180.0))) 2.0))
  55.    )
  56.    (setq p00 (polar p00 (angle p00 p01) fd) p00 (list (car p00) (cadr p00) (+ (caddr p00) fd)))
  57.    (setq p01 (polar p01 (angle p01 p00) fd) p01 (list (car p01) (cadr p01) (+ (caddr p01) fd)))
  58.    (setq p02 (polar p02 (angle p02 p03) fd) p02 (list (car p02) (cadr p02) (- (caddr p02) fd)))
  59.    (setq p03 (polar p03 (angle p03 p02) fd) p03 (list (car p03) (cadr p03) (- (caddr p03) fd)))
  60.    (setq en1 (subst (cons 10 p00) (assoc 10 en1) en1))
  61.    (setq en1 (subst (cons 11 p01) (assoc 11 en1) en1))
  62.    (setq en1 (subst (cons 12 p02) (assoc 12 en1) en1))
  63.    (setq en1 (subst (cons 13 p03) (assoc 13 en1) en1))
  64.    (entmod en1)
  65.    )
  66.    (princ "*▓╗╩╟╞╜├µ*")
  67.    ))
  68.    (setvar "blipmode" 1)
  69.    (setvar "highlight" 1)
  70.    (setvar "cmdecho" 1)
  71.    (setq *error* oer)
  72.    (princ)
  73. )
  74.