Raccord de polyligne spécial

[bonuscad]

Bonjour,

Pour répondre à une demande sur un forum j'ai été amené à créer ce code.

La demande portait sur le raccordement aux extrémités seulement de plusieurs polylignes (composées essentiellement de segments droits) se touchant à leurs extrémités mais étant sur des calques différents, par un rayon identique.

Ce raccord d'arc devait être composé en deux parties pour rejoindre le calque des polylignes concernées.

Bien que certainement inutile pour beaucoup (mais sait on jamais!), comme j'ai trouvé ce challenge intéressant, j'ai essayé d'y répondre. L’intéressé a été satisfait...

Voici le code (des bugs peuvent subsister car moyennement testé)

(defun z_dir (p1 p2 / )
  (trans
    '(0.0 1.0 0.0)
    (mapcar
      '(lambda (k)
        (/ k
          (sqrt
            (apply '+
              (mapcar
                '(lambda (x) (* x x))
                (mapcar '- p2 p1)
              )
            )
          )
        )
      )
      (mapcar '- p2 p1)
    )
    0
  )
)
(defun ang_x (px p1 p2 / l_pt l_d p ang)
  (setq
    l_pt (mapcar '(lambda (x) (list (car x) (cadr x) (caddr x))) (list px p1 p2))
    l_d (mapcar 'distance l_pt (append (cdr l_pt) (list (car l_pt))))
    p (/ (apply '+ l_d) 2.0)
    ang (* (atan (sqrt (/ (* (- p (car l_d)) (- p (caddr l_d))) (* p (- p (cadr l_d)))))) 2.0)
  )
)
(defun k_th (p1 p2 c / k)
  (setq k (/ c (distance p1 p2)))
  (mapcar '+ (mapcar '* (mapcar '- p2 p1) (list k k k)) p1)
)
(defun c:Spec_Fillet ( / js n ent lo_pt l_pt pt l3 js1 js2 alpha l_tg p_o a1 a2 dxf_210)
  (cond
    ((not (zerop (getvar "FILLETRAD")))
      (setq js (ssget '((0 . "LWPOLYLINE") (67 . 0))))
      (cond
        (js
          (repeat (setq n (sslength js))
            (setq
              ent (ssname js (setq n (1- n)))
              lo_pt (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget ent)))
              lo_pt (list (car lo_pt) (last lo_pt))
              lo_pt (mapcar '(lambda (z) (trans z 0 1)) lo_pt)
            )
            (if (null l_pt)
              (mapcar '(lambda (x) (setq l_pt (cons x l_pt))) lo_pt)
              (foreach el lo_pt
                (if (null (vl-remove-if-not '(lambda (x) (equal el x 1E-08)) l_pt))
                  (setq l_pt (cons el l_pt))
                )
              )
            )
          )
        )
      )
      (cond
        (l_pt
          (while l_pt
            (setq
              pt (car l_pt)
              js (ssget "_C" (mapcar '- pt '(0.05 0.05 0.0)) (mapcar '+ pt '(0.05 0.05 0.0)) '((0 . "LWPOLYLINE") (67 . 0)))
            )
            (cond
              ((and js (eq (sslength js) 2))
                (setq l3 (list pt))
                (repeat (setq n (sslength js))
                  (setq
                    ent (ssname js (setq n (1- n)))
                    lo_pt (mapcar '(lambda (z) (trans z 0 1)) (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget ent))))
                  )
                  (cond
                    ((and (> (length lo_pt) 2) (equal pt (car lo_pt) 1E-08))
                      (setq lo_pt (list (car lo_pt) (cadr lo_pt)))
                    )
                    ((and (> (length lo_pt) 2) (equal pt (last lo_pt) 1E-08))
                      (setq lo_pt (list (last lo_pt) (nth (- (length lo_pt) 2) lo_pt)))
                    )
                  )
                  (setq
                    lo_pt (vl-remove-if-not '(lambda (x) (not (equal pt x 1E-08))) lo_pt)
                    l3 (append l3 lo_pt)
                  )
                  (set (read (strcat "js" (itoa (1+ n)))) (entget ent))
                )
                (setq
                  alpha (ang_x (car l3) (cadr l3) (caddr l3))
                )
                (cond
                  ((not (equal alpha pi 1E-06))
                    (setq
                      l_tg (* (getvar "FILLETRAD") (/ 1.0 (/ (sin (* alpha 0.5)) (cos (* alpha 0.5)))))
                      p_o
                      (k_th
                        (car l3)
                        (mapcar
                          '*
                          (mapcar
                            '+
                            (polar (car l3) (angle (car l3) (cadr l3)) l_tg)
                            (polar (car l3) (angle (car l3) (caddr l3)) l_tg)
                          )
                          '(0.5 0.5 0.5)
                        )
                        (+ (getvar "FILLETRAD") (* (getvar "FILLETRAD") (1- (/ 1.0 (sin (* alpha 0.5))))))
                      )
                      a1 (angle p_o (car l3))
                      a2 (angle p_o (polar (car l3) (angle (car l3) (cadr l3)) l_tg))
                      dxf_210 (z_dir p_o (car l3))
                    )
                    (if (or (zerop a2) (and (eq (rem a1 (* 3.5 pi)) a1) (> a1 a2)))
                      (setq a2 (+ a2 (* 2 pi)))
                    )
                    (entmake
                      (list
                        (cons 0 "ARC")
                        (cons 100 "AcDbEntity")
                        (assoc 67 js2)
                        (assoc 410 js2)
                        (assoc 8 js2)
                        (if (assoc 62 js2) (assoc 62 js2) (cons 62 256))
                        (if (assoc 6 js2) (assoc 6 js2) (cons 6 "BYLAYER"))
                        (if (assoc 370 js2) (assoc 370 js2) '(370 . -1))
                        (cons 38 (+ (cdr (assoc 38 js2)) (getvar "ELEVATION")))
                        (cons 39 (getvar "THICKNESS"))
                        (cons 100 "AcDbCircle")
                        (cons 10 (trans p_o 1 dxf_210))
                        (cons 40 (getvar "FILLETRAD"))
                        (cons 210 dxf_210) 
                        (cons 100 "AcDbArc")
                        (cons 50 (if (and (< a1 a2) (<= (- a2 a1) pi)) (+ (angle '(0 0 0) (getvar "UCSXDIR")) a1) (+ (angle '(0 0 0) (getvar "UCSXDIR")) a2)))
                        (cons 51 (if (and (< a1 a2) (<= (- a2 a1) pi)) (+ (angle '(0 0 0) (getvar "UCSXDIR")) a2) (+ (angle '(0 0 0) (getvar "UCSXDIR")) a1)))
                      )
                    )
                    (setq
                      a2 (angle p_o (polar (car l3) (angle (car l3) (caddr l3)) l_tg))
                    )
                    (if (or (zerop a2) (and (eq (rem a1 (* 3.5 pi)) a1) (> a1 a2)))
                      (setq a2 (+ a2 (* 2 pi)))
                    )
                    (entmake
                      (list
                        (cons 0 "ARC")
                        (cons 100 "AcDbEntity")
                        (assoc 67 js1)
                        (assoc 410 js1)
                        (assoc 8 js1)
                        (if (assoc 62 js1) (assoc 62 js1) (cons 62 256))
                        (if (assoc 6 js1) (assoc 6 js1) (cons 6 "BYLAYER"))
                        (if (assoc 370 js1) (assoc 370 js1) '(370 . -1))
                        (cons 38 (+ (cdr (assoc 38 js1)) (getvar "ELEVATION")))
                        (cons 39 (getvar "THICKNESS"))
                        (cons 100 "AcDbCircle")
                        (cons 10 (trans p_o 1 dxf_210))
                        (cons 40 (getvar "FILLETRAD"))
                        (cons 210 dxf_210) 
                        (cons 100 "AcDbArc")
                        (cons 50 (if (and (< a1 a2) (<= (- a2 a1) pi)) (+ (angle '(0 0 0) (getvar "UCSXDIR")) a1) (+ (angle '(0 0 0) (getvar "UCSXDIR")) a2)))
                        (cons 51 (if (and (< a1 a2) (<= (- a2 a1) pi)) (+ (angle '(0 0 0) (getvar "UCSXDIR")) a2) (+ (angle '(0 0 0) (getvar "UCSXDIR")) a1)))
                      )
                    )
                  )
                )
              )
            )
            (setq l_pt (cdr l_pt))
          )
        )
      )
    )
    (T (princ "\nFILLETRAD doit être différent de zéro"))
  )
  (prin1)
)

 

[didier]

Bonjour @bonuscad

Chouette idée, merci de la partager

Amicalement