[编程交流] 自动fillet-trim

(defun c:foo (/ acc ss)
  (setq acc (getvar "PEDITACCEPT"))
  (if (setq ss (ssget '((0 . "ARC,*POLYLINE,LINE"))))
    (progn
      (setvar "PEDITACCEPT" 1)
      (command "_.pedit" "_M" ss "" "_J" "100" "") ; Fill in a large enough fuzz here
    )
  )
  (setvar "PEDITACCEPT" acc)
  (princ)
)

(defun c:redrawcrossings ( / *error* _inters ss i lil ip )
  (defun *error* ( m )
    (if m
      (prompt m)
    )
    (princ)
  )
  (defun _inters ( l1 l2 / v^v unit pl1 pl2 x1 x2 x3 x4 y1 y2 y3 y4 z1 z2 z3 z4 v1 v2 n xi1 yi1 zi1 xi2 yi2 zi2 d1 d2 d3 ip )
    (setq pl1 (mpacar (function cdr) (vl-remove-if (function (lambda ( x ) (vl-position (car x) (list 10 11)))) (entget l1))))
    (setq x1 (car (car pl1)) y1 (cadr (car pl1)) z1 (caddr (car pl1)) x2 (car (cadr pl1)) y2 (cadr (cadr pl1)) z1 (caddr (cadr pl1)))
    (setq pl2 (mpacar (function cdr) (vl-remove-if (function (lambda ( x ) (vl-position (car x) (list 10 11)))) (entget l2))))
    (setq x3 (car (car pl2)) y3 (cadr (car pl2)) z3 (caddr (car pl2)) x4 (car (cadr pl2)) y4 (cadr (cadr pl2)) z4 (caddr (cadr pl2)))
    ;;; Xx1 + Yy1 + Zz1 = Q ;;; Xx2 + Yy2 + Zz2 = Q ;;; Xx3 + Yy3 + Zz3 = W ;;; Xx4 + Yy4 + Zz4 = W ;;; Xxi + Yyi + Zzi = Q ;;; Xxi + Yyi + Zzi = W ;;;
    ;;; X(x1-x2) + Y(y1-y2) + Z(z1-z2) = 0 ;;; x1-x2=A , y1-y2=B , z1-z2=C
    ;;; X(x1-xi) + Y(y1-yi) + Z(z1-zi) = 0 ;;; x1-xi=a , y1-yi=b , z1-zi=c
    ;;; X(x2-xi) + Y(y2-yi) + Z(z2-zi) = 0 ;;; x2-xi=d , y2-yi=e , z2-zi=f
    ;;; X(x3-x4) + Y(y3-y4) + Z(z3-z4) = 0 ;;; x3-x4=G , y3-y4=H , z3-z4=I
    ;;; X(x3-xi) + Y(y3-yi) + Z(z3-zi) = 0 ;;; x3-xi=g , y3-yi=h , z3-zi=i
    ;;; X(x4-xi) + Y(y4-yi) + Z(z4-zi) = 0 ;;; x4-xi=j , y4-yi=k , z4-zi=l
    ;;; A*b*I + B*c*G + C*a*H - G*b*C - H*c*A - I*a*B = 0
    ;;; A*e*I + B*f*G + C*d*H - G*e*C - H*f*A - I*d*B = 0
    ;;; A*h*I + B*i*G + C*g*H - G*h*C - H*i*A - I*g*B = 0
    ;;; A*k*I + B*l*G + C*j*H - G*k*C - H*l*A - I*j*B = 0
    ;;; ------------------------------------------------- ;;;
    (setq v1 (list (- x2 x1) (- y2 y1) (- z2 z1)))
    (setq v2 (list (- x4 x3) (- y4 y3) (- z4 z3)))
    (defun v^v ( u v )
      (list
        (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
        (- (* (caddr u) (car v)) (* (car u) (caddr v)))
        (- (* (car u) (cadr v)) (* (cadr u) (car v)))
      )
    )
    (defun unit ( v / d )
      (if (not (equal (setq d (distance v (list 0.0 0.0 0.0))) 0.0 1e-8))
        (mapcar (function (lambda ( x ) (/ x d))) v)
        (prompt "\ncatched error in (unit) - invalid input - reference vector strength near 0.0")
      )
    )
    (setq n (v^v v1 v2))
    (setq n (v^v n v1))
    ;;; x1(xi1-(car n)) + y1(yi1-(cadr n)) + z1(zi1-(caddr n)) = x3(xi1-(car v2)) + y3(yi1-(cadr v2)) + z3(zi1-(caddr v2))
    ;;; x2(xi2-(car n)) + y2(yi2-(cadr n)) + z2(zi2-(caddr n)) = x3(xi2-(car v2)) + y3(yi2-(cadr v2)) + z3(zi2-(caddr v2))
    ;;; x1(xi1-(car n)) = x3(xi1-(car v2)) ;;; x1xi1-x1(car n) = x3xi1-x3(car v2) ;;; xi1(x1-x3) = x1(car n)-x3(car v2)
    ;;; xi1 = [x1(car n)-x3(car v2)]/(x1-x3)
    ;;; yi1 = [y1(cadr n)-y3(cadr v2)]/(y1-y3)
    ;;; zi1 = [z1(caddr n)-z3(caddr v2)]/(z1-z3)
    ;;; xi2 = [x2(car n)-x3(car v2)]/(x2-x3)
    ;;; yi2 = [y2(cadr n)-y3(cadr v2)]/(y2-y3)
    ;;; zi2 = [z2(caddr n)-z3(caddr v2)]/(z2-z3)
    (setq xi1 (/ (- (* x1 (car n)) (* x3 (car v2))) (- x1 x3)))
    (setq yi1 (/ (- (* y1 (cadr n)) (* y3 (cadr v2))) (- y1 y3)))
    (setq zi1 (/ (- (* z1 (caddr n)) (* z3 (caddr v2))) (- z1 z3)))
    (setq xi2 (/ (- (* x2 (car n)) (* x3 (car v2))) (- x2 x3)))
    (setq yi2 (/ (- (* y2 (cadr n)) (* y3 (cadr v2))) (- y2 y3)))
    (setq zi2 (/ (- (* z2 (caddr n)) (* z3 (caddr v2))) (- z2 z3)))
    (if (equal (unit (list (- xi1 x1) (- yi1 y1) (- zi1 z1))) (unit (list (- xi2 x2) (- yi2 y2) (- zi2 z2))) 1e-6)
      (progn
        (setq d1 (distance (list x1 y1 z1) (list xi1 yi1 zi1)))
        (setq d2 (distance (list x2 y2 z2) (list xi2 yi2 zi2)))
        (setq d3 (distance (list x1 y1 z1) (list x2 y2 z2)))
        (setq ip (mapcar (function +) (list x3 y3 z3) (mapcar (function *) (unit v2) (list (* (/ (- d2 d1) d3) d2) (* (/ (- d2 d1) d3) d2) (* (/ (- d2 d1) d3) d2)))))
      )
    )
  )
  (prompt "\nSelect lines...")
  (setq ss (ssget "_:L" (list (cons 0 "LINE"))))
  (repeat (setq i (sslength ss))
    (setq lil (cons (ssname ss (setq i (1- i))) lil))
  )
  (foreach li1 lil
    (setq lil (cdr lil))
    (foreach li2 lil
      (setq ip (_inters li1 li2))
      (if ( : "))
  (if (not fuzz)
    (setq fuzz 1.0)
  )
  (prompt "\nSelect lines...")
  (setq ss (ssget "_:L" (list (cons 0 "LINE"))))
  (repeat (setq i (sslength ss))
    (setq lil (cons (ssname ss (setq i (1- i))) lil))
  )
  (foreach li1 lil
    (setq lil (cdr lil))
    (foreach li2 lil
      (setq ip (_inters li1 li2))
      (cond
        ( (fuzzchk (cdr (assoc 10 (setq li1x (entget li1)))) ip fuzz)
          (entupd (cdr (assoc -1 (entmod (subst (cons 10 ip) (assoc 10 li1x) li1x)))))
        )
        ( (fuzzchk (cdr (assoc 11 li1x)) ip fuzz)
          (entupd (cdr (assoc -1 (entmod (subst (cons 11 ip) (assoc 11 li1x) li1x)))))
        )
      )
      (cond
        ( (fuzzchk (cdr (assoc 10 (setq li2x (entget li2)))) ip fuzz)
          (entupd (cdr (assoc -1 (entmod (subst (cons 10 ip) (assoc 10 li2x) li2x)))))
        )
        ( (fuzzchk (cdr (assoc 11 li2x)) ip fuzz)
          (entupd (cdr (assoc -1 (entmod (subst (cons 11 ip) (assoc 11 li2x) li2x)))))
        )
      )
    )
  )
  (*error* nil)
)