浩辰暖通4-Int4的lisp程序

crtrccrt

(defun c:ac_fgss( / el en e bly blz )
  (setvar "CMDECHO" 0)
  (setvar "osmode" 0)
  (while (/= (setq el (~elpipe (entsel "\n选择风管<回车结束>:"))) NIL)
    (setq en (car el) pt (cadr el) e (entget en)
          p0 (cdr (assoc 10 e)) a0 (cdr (assoc 50 e))
         bly (cdr (assoc 42 e)) blz (cdr (assoc 43 e))
         blx (cdr (assoc 41 e)) p1 (polar p0 a0 blx))
    (redraw en 3)
    (if (< (distance pt p0) (distance pt p1))
      (setq pp p0 a (angle p1 p0)) (setq pp p1 a (angle p0 p1)))
    (setq pnew (getpoint pp "\n给出新点<回车不变>:")
          pnew (list (nth 0 pnew) (nth 1 pnew) (nth 2 p0)))
    (if (/= pnew NIL) (progn
      (setq pnew (inters p0 p1 pnew (polar pnew (+ _pi2 (angle p0 p1)) 100) NIL))
     (if (equal (+ (distance pnew p0) (distance pnew p1)) (distance p0 p1) 0.1)
        (setq aa (+ a pi)) (setq aa a))
      (setq pnew (polar pp aa (distance pp pnew)))
      (if (< (distance pp p0) (distance pp p1))
        (setq e (subst (cons 10 pnew) (assoc 10 e) e)))
      (if (equal aa a 0.011)
        (if (> blx 0)
          (setq e (subst (cons 41 (+ blx (distance pp pnew)))
                         (assoc 41 e) e))
          (setq e (subst (cons 41 (- blx (distance pp pnew)))
                         (assoc 41 e) e))
        )
        (if (> blx 0)
          (setq e (subst (cons 41 (- blx (distance pp pnew)))
                         (assoc 41 e) e))
          (setq e (subst (cons 41 (+ blx (distance pp pnew)))
                         (assoc 41 e) e))
        )
      )
      (entmod e)
    ) )
  )
  (princ)
)

(defun c:ac_fgdd( / el en e bly blz )
  (setvar "CMDECHO" 0)
  (setvar "osmode" 0)
  (while (/= (setq el (~elpipe (entsel "\n选择风管<回车结束>:"))) NIL)
    (setq en (car el) pt (cadr el) e (entget en)
          p0 (cdr (assoc 10 e)) a0 (cdr (assoc 50 e))
         bly (cdr (assoc 42 e)) blz (cdr (assoc 43 e))
         blx (cdr (assoc 41 e)) p00 (polar p0 a0 blx))
    (redraw en 3)
    (if (< (distance pt p0) (distance pt p00))
      (setq pp p0 a (angle p00 p0)) (setq pp p00 a (angle p0 p00)))
    (setq pnew (getpoint pp "\n给出断点<回车不断>:"))
    (if (/= pnew NIL) (progn
      (setq pnew (list (nth 0 pnew) (nth 1 pnew) (nth 2 p0)))
      (if (/= pnew NIL) (progn
        (setq pnew (inters p0 p00 pnew (polar pnew (+ _pi2 (angle p0 p00)) 100) NIL))
        (if (equal (+ (distance pnew p0) (distance pnew p00)) (distance p0 p00) 0.1)
          (progn
;           (command "color" (cdr (assoc 62 e)))
            (~set-layer (cdr (assoc 8 e)))
            (command "copy" en "" p0 p0)
            (setq en1 (entlast) e1 (entget en1))
            (if (> (distance p0 pnew) (distance p00 pnew))
              (if (> blx 0)
                (setq e (subst (cons 41 (distance p0 pnew)) (assoc 41 e) e)
                     e1 (subst (cons 10 pnew) (assoc 10 e1) e1)
                     e1 (subst (cons 41 (distance p00 pnew)) (assoc 41 e1) e1))
                (setq e (subst (cons 41 (- (distance p0 pnew))) (assoc 41 e) e)
                     e1 (subst (cons 10 pnew) (assoc 10 e1) e1)
                     e1 (subst (cons 41 (- (distance p00 pnew))) (assoc 41 e1) e1))
              )
              (if (> blx 0)
                (setq e1 (subst (cons 41 (distance p0 pnew)) (assoc 41 e1) e1)
                       e (subst (cons 10 pnew) (assoc 10 e) e)
                       e (subst (cons 41 (distance p00 pnew)) (assoc 41 e) e))
                (setq e1 (subst (cons 41 (- (distance p0 pnew))) (assoc 41 e1) e1)
                       e (subst (cons 10 pnew) (assoc 10 e) e)
                       e (subst (cons 41 (- (distance p00 pnew))) (assoc 41 e) e))
              )
            )
            (entmod e)(entmod e1)(redraw en1)
        ) )
      ) )
    ) )
    (redraw en)
  )
  (princ)
)

(defun c:ac_fghb( / el en e pt enp ep )
  (setvar "CMDECHO" 0)
  (setvar "osmode" 0)
  (while (/= (setq el (~elpipe (entsel "\n选择风管<回车结束>:"))) NIL)
    (setq en (car el) pt (cadr el) e (entget en))
    (redraw en 3)
    (setq el (~elpipe (entsel "\n选择合并风管<回车结束>:")))
    (if (/= el NIL) (progn
      (setq enp (car el) pt (cadr el) ep (entget enp))
      (~pjoin en enp)
    ) )
  )
  (princ)
)

(defun ~pjoin( en enp / en e blx bly blz enp ep blx1 bly1 blz1 p0 a0 p00 p1 a1 p10 )
  (setq  e (entget en)
        p0 (cdr (assoc 10 e)) a0 (cdr (assoc 50 e))
       bly (cdr (assoc 42 e)) blz (cdr (assoc 43 e))
       blx (cdr (assoc 41 e)) p00 (polar p0 a0 blx) blx0 blx)
  (setq  ep (entget enp)
         p1 (cdr (assoc 10 ep)) a1 (cdr (assoc 50 ep))
       bly1 (cdr (assoc 42 ep)) blz1 (cdr (assoc 43 ep))
       blx1 (cdr (assoc 41 ep)) p10 (polar p1 a1 blx1))
  (if (and (equal bly bly1 0.01) (equal blz blz1 0.01)
           (= (t:inters p0 p00 p1 p10 NIL) NIL)
           (= (cdr (assoc 8 e)) (cdr (assoc 8 ep)))
           (equal (nth 2 p0) (nth 2 p1) 0.1)) (progn
    (setq blx (max (distance p0 p1) (distance p0 p10)
                   (distance p00 p1) (distance p00 p10)))
    (entdel enp)
    (if (< (distance p0 p1) (distance p00 p1))
      (if (> blx0 0)
        (setq e (subst (cons 10 (polar p00 (+ a0 pi) blx))
                       (assoc 10 e) e))
        (setq e (subst (cons 10 (polar p00 (+ a0 pi) (- blx)))
                       (assoc 10 e) e))
      )
    )
    (if (> blx0 0)
      (setq e (subst (cons 41 blx) (assoc 41 e) e))
      (setq e (subst (cons 41 (- blx)) (assoc 41 e) e))
    )
    (entmod e)
  ) )
  (redraw en)
)

(setq sca 1.0)
(defun c:ac_fgcx( / el en e tkn lst lay col pl lch lev )
  (setvar "CMDECHO" 0)
  (setvar "osmode" 0)
  (chk1-lsp "ac_gdfs" "c:ac_gdfs")
  (while (/= (setq el (~elpipe (entsel "\n选择查询风管<回车结束>: "))) NIL)
    (setq en (car el) e (entget en) tkn (cdr (assoc 0 e))
         lay (cdr (assoc 8 e))
         col (cdr (assoc 62 (tblsearch "LAYER" lay))))
    (setq lev 0)
    (if (and (= "INSERT" tkn)
             (= "A-PSF" (substr (setq tkn (cdr (assoc 2 e))) 1 5)))
      (progn
        (setq lst (~getpipe en))
        (if (= (substr lay 1 3) "AC_") (progn
          (setq pl (list (nth 3 lst) (nth 4 lst) (- (nth 5 lst) lev) (nth 6 lst)
                               (nth 7 lst) (nth 8 lst) (nth 9 lst) (nth 10 lst)
                               lay col
          )              )
          (setq ~ac_lev0 ~ac_lev1
                ~ac_lev1 (+ (- (nth 5 lst) lev) (/ (cdr (assoc 41 e)) sca)))
          (if (and (> (strlen tkn) 6) (= (substr tkn 7 1) "L"))
            (setq pll (c:ac_gdfs pl 1))
            (setq pll (c:ac_gdfs pl 0))
          )
          (if (or (not (equal pl pll)) (/= ~ac_lev1 ~ac_lev0)) (progn
            (setq e (subst (cons 8 (nth 8 pll)) (assoc 8 e) e)
                  e (subst (cons 42 (* sca (nth 0 pll))) (assoc 42 e) e)
                  e (subst (cons 43 (* sca (nth 1 pll))) (assoc 43 e) e))
            (if (and (> (strlen tkn) 6) (= (substr tkn 7 1) "L"))
              (progn
                (if (= 1 (nth 3 pll))
                  (setq e (subst (cons 2 "A-PSFYL") (assoc 2 e) e))
                  (setq e (subst (cons 2 "A-PSFJL") (assoc 2 e) e))
                )
   (setq e (subst (cons 41 (- (last pll) (nth 2 pll))) (assoc 41 e) e))
;               (setq e (subst (cons 41 (* sca (- ~ac_lev1 (nth 5 pll))))
;                              (assoc 41 e) e))
              )
              (if (= 1 (nth 3 pll))
                (setq e (subst (cons 2 "A-PSFY") (assoc 2 e) e))
                (setq e (subst (cons 2 "A-PSFJ") (assoc 2 e) e))
              )
            )
            (entmod e)
            (if (equal (nth 1 pl) (nth 1 pll) 0.1) NIL
              (progn
              (setq mfs (t:ts getstring
                        "\n选变径垂直对齐边[L]-底, [U]-顶, [C]-轴线" "L"))
              (cond ((= (strcase mfs) "L")
                     (command "move" en "" '(0 0 0)
                            (list 0 0 (* sca (- (nth 1 pll) (nth 1 pl)) 0.5)))
                    )
                    ((= (strcase mfs) "U")
                     (command "move" en "" '(0 0 0)
                            (list 0 0 (* sca (- (nth 1 pl) (nth 1 pll)) 0.5)))
                    )
              )
            ) )
            (if (equal (nth 2 pl) (nth 2 pll) 0.1) NIL
              (command "move" en "" '(0 0 0)
                       (list 0 0 (* sca (- (nth 2 pll) (nth 2 pl)))))
            )
            (setq st (strcat "(" (itoa (nth 3 pll)) " \""
                                 (nth 4 pll) "\" " (rtos (nth 5 pll) 2 0)
                              " " (rtos (nth 6 pll) 2 0) " "
                                  (rtos (nth 7 pll) 2 0) ")")
                  ee (entget (entnext en))
                  ee (subst (cons 2 st) (assoc 2 ee) ee))
            (entmod ee)
          ) )
          (setq ~ac_lev1 ~ac_lev0)
        ) )
      )
      (progn
        (alert "所选实体非风管道!!!")
    ) )
  )
  (princ)
)

(defun ~getpipe( en / e p0 p1 a ll bx by plist bh sys_lev ccla )
  (setq e (entget en) p0 (cdr (assoc 10 e)) plist NIL
       ll (cdr (assoc 41 e)) bx (/ (cdr (assoc 42 e)) sca)
       by (/ (cdr (assoc 43 e)) sca)
        a (cdr (assoc 50 e)) spp (cdr (assoc 210 e)))
  (setq bh (/ (nth 2 p0) sca))
  (if (= bh NIL) (setq bh 0))
  (if (/= (substr (cdr (assoc 2 e)) 1 5) "A-PSF")
    (princ "\n所选实体不是风管, 请重新选择!!!")
    (progn
      (if (equal (list 0.0 0.0 1.0) spp) (setq spp NIL))
      (if (= spp NIL)
        (progn
          (setq plist (cons spp plist) plist (cons p0 plist)
                p1 (polar p0 a ll) plist (cons p1 plist)
          )
          (if (= (cdr (assoc 2 e)) "A-PSFJ")
            (setq bh (- bh (/ by 2.0))))
        )
        (setq p1 (polar p0 0 ll)
              p0 (trans p0 spp 0) p1 (trans p1 spp 0)
              plist (cons spp plist) bh (/ (nth 2 p0) sca)
              plist (cons p0 plist) plist (cons p1 plist))
      )
      (setq plist (cons (/ (cdr (assoc 42 e)) sca) plist)
            plist (cons (/ (cdr (assoc 43 e)) sca) plist) lst (~gattp en))
      (setq plist (cons bh plist)
            plist (cons (nth 0 lst) plist)
            plist (cons (nth 1 lst) plist)
            plist (cons (nth 2 lst) plist)
            plist (cons (nth 3 lst) plist)
            plist (cons (nth 4 lst) plist)
            plist (reverse plist))
  ) )
  plist
)
(princ)


liuyj

缺函数，不能运行。

啵浪鼓

搞不懂这些程序用来做什么的

tsxljj

这些lsp好像都需要arx支持才行，