home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / OPM.LSP < prev    next >
Encoding:
Text File  |  1992-01-30  |  5.5 KB  |  127 lines
  1. (defun opmerr(s)
  2.   (if (/= s "Function cancelled")
  3.       (princ (strcat "\nError:" s))
  4.   )
  5.   (command "undo" "end")
  6.   (command "layer" "s" "0" "")
  7.   (setvar "cmdecho" 1)
  8.   (setq *error* oer)
  9.   (princ)
  10. )
  11.  
  12. (defun c:opm(/ oer ss ssl sn en ename elay q10 q11 q12 q13 yx10 yx11 yx12 yx13 qz10 qz11 qz12 qz13 cnt n0
  13.  pl03 pl12 ssa ssb p10 p11 p12 p13 xy10 xy11 xy12 xy13 z10 z11 z12 z13 sns minv maxv pl03s pl12s loop n1
  14.  03s n2 a2 b2 a1 b1 a0 ecol enl q70 f71 f72)
  15.    (setvar "cmdecho" 0)
  16.    (setq oer *error* *error* opmerr)
  17.    (command "undo" "g")
  18.    (setq ss (ssget))
  19.    (if ss (progn 
  20.      (setq ssl (sslength ss) n 0 cnt 0)
  21.      (princ "\nProcessing ......")
  22.      (while (> ssl 0)
  23.        (if (setq sn (ssname ss n)) (progn
  24.        (setq en (entget sn) ename (cdr (assoc 0 en)) elay (cdr (assoc 8 en)))
  25.        (cond ((and (= "TWALL" elay) (= "3DFACE" ename))
  26.          (setq q10 (cdr (assoc 10 en)) q11 (cdr (assoc 11 en)))
  27.          (setq q12 (cdr (assoc 12 en)) q13 (cdr (assoc 13 en)))
  28.          (setq q70 (cdr (assoc 70 en)) ecol (cdr (assoc 62 en)))
  29.          (setq yx10 (list (car q10) (cadr q10)) qz10 (caddr q10))
  30.          (setq yx11 (list (car q11) (cadr q11)) qz11 (caddr q11))
  31.          (setq yx12 (list (car q12) (cadr q12)) qz12 (caddr q12))
  32.          (setq yx13 (list (car q13) (cadr q13)) qz13 (caddr q13))
  33.          (setq cnt (1+ cnt))
  34.          (if (and (equal yx10 yx13 1) (equal yx11 yx12 1)) (progn
  35.          (setq n0 0 pl03 () pl12 () ssa nil ssa (ssadd) ssb nil ssb (ssadd))
  36.          (setq pl03 (cons qz10 pl03) pl03 (cons qz13 pl03))
  37.          (setq pl12 (cons qz11 pl12) pl12 (cons qz12 pl12))
  38.          (while (< n0 ssl)
  39.            (if (and (setq sns (ssname ss n0))(not (eq sns sn)))(progn
  40.              (setq ens (entget sns) enames (cdr (assoc 0 ens)) elays (cdr (assoc 8 ens)))
  41.              (if (and (= "TWALL" elays) (= "3DFACE" enames)) (progn
  42.                (setq p10 (cdr (assoc 10 ens)) p11 (cdr (assoc 11 ens)))
  43.                (setq p12 (cdr (assoc 12 ens)) p13 (cdr (assoc 13 ens)))
  44.                (setq xy10 (list (car p10) (cadr p10)) z10 (caddr p10))
  45.                (setq xy11 (list (car p11) (cadr p11)) z11 (caddr p11))
  46.                (setq xy12 (list (car p12) (cadr p12)) z12 (caddr p12))
  47.                (setq xy13 (list (car p13) (cadr p13)) z13 (caddr p13))
  48.                (if (and (equal yx10 xy10 1) (equal yx10 xy13 1) (equal yx11 xy11 1) (equal yx11 xy12 1)) (progn
  49.                   (setq pl03 (cons z10 pl03) pl03 (cons z13 pl03))
  50.                   (setq pl12 (cons z11 pl12) pl12 (cons z12 pl12))
  51.                   (ssadd sns ssa)
  52.                ))
  53.             )(ssadd sns ssb))
  54.          ))
  55.          (setq n0 (1+ n0))
  56.         ) ;end while
  57. ;(princ "\n$1")(princ pl03)
  58. ;(princ "\n$2")(princ pl12)
  59.         (if (and (> (length pl03) 2) (not (= pl03 ()))) (progn
  60.         (setq l (length pl03) minv -999999.0 pl03s () pl12s ())
  61.         (repeat l
  62.         (setq maxv (apply 'max pl03))
  63.         (setq loop t n1 0)
  64.         (while (and loop (< n1 l))
  65.           (if (= maxv (nth n1 pl03)) (setq loop nil) (setq n1 (1+ n1)))
  66.         )
  67.           (setq 03s () n2 (1- n1))
  68.           (while (>= n2 0) (setq 03s (cons (nth n2 pl03) 03s) n2 (1- n2)))
  69.           (setq pl03 (append 03s (list minv) (cdr (member maxv pl03))))
  70.           (setq pl03s (cons maxv pl03s) pl12s (cons (nth n1 pl12) pl12s))
  71.         ) ;rep
  72. ;(princ "\n*1")(princ pl03s)
  73. ;(princ "\n*2")(princ pl12s)
  74.       (setq l (length pl03s) n0 0 pl03 () pl12 () a0 nil)
  75.       (setq a2 pl03s b2 pl12s)
  76.       (while (< n0 l)
  77.          (setq a1 (car a2) a2 (cdr a2))
  78.          (setq b1 (car b2) b2 (cdr b2))
  79.          (if (and (not (= a1 a0))(not (member a1 a2))) (setq pl03 (cons a1 pl03) pl12 (cons b1 pl12)))
  80.          (setq a0 a1 n0 (1+ n0))
  81.       )
  82.       (setq pl03 (reverse pl03) pl12 (reverse pl12) l0 l l (length pl03))
  83.       (if (and (< l l0) (= (* (/ l 2.0) 2) l)) (progn
  84.         (entdel sn) (command "erase" ssa "")
  85.         (if (not (= (getvar "clayer") elay)) (command "layer" "s" elay ""))
  86.         (if (not (= ecol (getvar "cecolor"))) (if (not (= ecol nil)) (command "color" ecol) (command "color" "bylayer")))
  87.         (setq n0 0)
  88.         (repeat (/ l 2)
  89.            (command "3dface" (append yx10 (list (nth n0 pl03))) (append yx11 (list (nth n0 pl12))) (append yx12 (list (nth (1+ n0) pl12))) (append yx13 (list (nth (1+ n0) pl03))) "")
  90.            (setq enl (entget (entlast)))
  91.            (setq q70 (logior (logand q70 10) 5))
  92.            (if (= n0 0) (setq q70 (logior (logand q70 10) 4)))
  93.            (if (= n0 (- l 2)) (setq q70 (logior (logand q70 10) 1)))
  94.            (if (= l 2) (setq q70 (logand q70 10)))
  95.            (setq enl (subst (cons 70 q70) (assoc 70 enl) enl))
  96.            (entmod enl)
  97.            (setq n0 (+ n0 2))
  98.         )
  99.      ))
  100.       )) ;= pl03 nil
  101.       )) ;endif vertical face
  102.       ) ;cond1
  103.      ((= ename "POLYLINE")
  104.       (setq f71 (cdr (assoc 71 en)) f72 (cdr (assoc 72 en)))
  105.       (if (and (> f71 0) (> f72 0)) (progn
  106.       (command "explode" sn)
  107.       )))
  108.       ) ;end cond
  109.       (ssdel sn ss)
  110.       (setq n0 0)
  111.       (if ssb
  112.       (repeat (sslength ssb) (ssdel (ssname ssb n0) ss) (setq n0 (1+ n0))))
  113.       (setq n0 0)
  114.       (if ssa
  115.       (repeat (sslength ssa) (ssdel (ssname ssa n0) ss) (setq n0 (1+ n0))))
  116.       (setq ssl (sslength ss) n -1)
  117.       )) ;endif sn
  118.     (setq n (1+ n))
  119.     ) ;end while
  120.     )) ;endif ss
  121.    (command "layer" "s" "0" "")
  122.    (command "undo" "end")
  123.    (setq *error* oer)
  124.    (setvar "cmdecho" 1)
  125.    (princ cnt) (princ " done.") (princ)
  126. )
  127.