Author Topic: Seek help:Don't make slug holes in the filleted or chamfered corner  (Read 1534 times)

0 Members and 1 Guest are viewing this topic.

2e4lite

  • Guest
  The following is the routine can draw slug holes in some polylines.The question now is what is drawn may occur error when the polyline is  filleted or chamfered .I hope it won't make slug holes in the filleted or chamfered corner . Who can help me to modify it .It will a great help to me.Thanks!

Code - Auto/Visual Lisp: [Select]
  1.  (defun c:esc(/ TK1 TK2 KD A R SS N E IntersLineCircle gxl-Ax:2DPoint gxl-clock )
  2. (defun IntersLineCircle ( p q c r / a d n s )
  3.   (setq n (mapcar '- q p)
  4.         p (trans p 0 n)
  5.         c (trans c 0 n)
  6.         a (list (car p) (cadr p) (caddr c))
  7.   )
  8.   (cond
  9.     ( (equal r (setq d (distance c a)))
  10.       (list (trans a n 0))
  11.     )
  12.     ( (< d r)
  13.       (setq s (sqrt (- (* r r) (* d d))))
  14.       (list
  15.         (trans (list (car p) (cadr p) (- (caddr c) s)) n 0)
  16.         (trans (list (car p) (cadr p) (+ (caddr c) s)) n 0)
  17.       )
  18.     )
  19.   )
  20. )
  21. (defun gxl-Ax:2DPoint (pt)
  22.   (vlax-make-variant
  23.       (vlax-make-safearray vlax-vbdouble '(0 . 1))
  24.       (list (car pt) (cadr pt))
  25.     )
  26.   )
  27. )
  28. (defun gxl-clock  (PLIST / LW MINP MAXP LST)
  29.   (cond   ((= 'LIST (type plist))
  30.      (not
  31.        (minusp
  32.          (apply '+
  33.            (mapcar
  34.              (function
  35.           (lambda (a b)
  36.             (- (* (car b) (cadr a)) (* (car a) (cadr b)))
  37.           )
  38.              )
  39.              plist
  40.              (cons (last plist) plist)
  41.            )
  42.          )
  43.        )
  44.      )
  45.    )
  46.    (t
  47.     (if (= 'ename (type plist))
  48.       (setq lw (vlax-ename->vla-object plist))
  49.       (if (= 'VLA-OBJECT (type plist))
  50.         (setq lw plist)
  51.         )
  52.       )
  53.     (vla-GetBoundingBox lw 'MinP 'MaxP)
  54.     (setq
  55.       minp   (vlax-safearray->list minp)
  56.       MaxP   (vlax-safearray->list MaxP)
  57.       lst   (mapcar
  58.         (function
  59.           (lambda (x)
  60.             (vlax-curve-getParamAtPoint
  61.          lw
  62.          (vlax-curve-getClosestPointTo lw x)
  63.          )
  64.             )
  65.           )
  66.         (list   minp
  67.          (list (car MaxP) (cadr minp))
  68.          MaxP
  69.          (list (car minp) (cadr MaxP))
  70.          )
  71.         )
  72.       )
  73.     (if (or
  74.           (<= (car lst) (cadr lst) (caddr lst) (cadddr lst))
  75.           (<= (cadr lst) (caddr lst) (cadddr lst) (car lst))
  76.           (<= (caddr lst) (cadddr lst) (car lst) (cadr lst))
  77.           (<= (cadddr lst) (car lst) (cadr lst) (caddr lst))
  78.           )
  79.       t
  80.       )
  81.     )
  82.    )
  83.   )
  84.  
  85.   (defun tk1 (E A      R      /      N      EL     I      P1     P2
  86.                 P3     CLOCKWISEP    MIDANG CP     MRP    STP    ENP
  87.                 MP     BULGE  ARCDATA       OBJ A1 A2
  88.                 )
  89.     (setq obj (vlax-ename->vla-object e))
  90.     (vla-put-Closed obj :vlax-true)
  91.     (setq n (fix (vlax-curve-getEndParam obj)))
  92.     ;(if (/= 1 (logand (cdr (assoc 70 el)) 1)) (setq n (- n 2)))
  93.     (setq i 0)
  94.     (repeat n
  95.       (setq p1 (vlax-curve-getPointAtParam e i)
  96.             p2 (vlax-curve-getPointAtParam e (setq i (1+ i)))
  97.             p3 (vlax-curve-getPointAtParam e (1+ i))
  98.             )
  99.       (if (null p3) (setq p3 (vlax-curve-getPointAtParam e 1)))
  100.       (setq a1 (angle p2 p1)
  101.             a2 (angle p2 p3)
  102.             )
  103.       (setq clockwisep
  104.              (<
  105.                (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
  106.                (* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
  107.                )
  108.             )
  109.       (if (< a1 a2) (setq a1 (+ a1 pi pi)))
  110.       (setq midang (* 0.5 (+ a1 a2)))
  111.       (if clockwisep
  112.         (setq cp (polar p2 midang (- a r))
  113.               mrp (polar p2 midang a)
  114.               )
  115.         (setq cp (polar p2 midang (- r a))
  116.               mrp (polar p2 midang (- a))
  117.               )
  118.         )
  119.       (setq stp (car (vl-remove-if-not
  120.                        '(lambda (x)
  121.                           (equal (+ (distance p1 x) (distance p2 x))
  122.                                  (distance p1 p2)
  123.                                  1e-6
  124.                                  )
  125.                           )
  126.                        (IntersLineCircle p2 p1 cp r)
  127.                        )
  128.                      )
  129.             )
  130.       (setq enp (car (vl-remove-if-not
  131.                        '(lambda (x)
  132.                           (equal (+ (distance p3 x) (distance p2 x))
  133.                                  (distance p3 p2)
  134.                                  1e-6
  135.                                  )
  136.                           )
  137.                        (IntersLineCircle p2 p3 cp r)
  138.                        )
  139.                      )
  140.             )
  141.       (setq mp (mapcar '* '(0.5 0.5 0.5) (MAPCAR '+ stp enp)))
  142.       (setq bulge (/ (distance mrp mp) (distance mp stp)))
  143.       (if clockwisep (setq bulge (- bulge)))
  144.       (setq arcdata (cons (list stp enp bulge) arcdata))
  145.       )
  146.     (setq  arcdata (reverse arcdata))
  147.     (foreach data arcdata
  148.       (setq stp (car data)
  149.             enp (cadr data)
  150.             bulge (caddr data)
  151.             )
  152.                      obj
  153.                      (vlax-curve-getclosestpointto obj enp)
  154.                      )
  155.                    )
  156.             )
  157.       (vla-put-coordinate obj n (GXL-AX:2DPOINT stp))
  158.       (if (vlax-curve-getPointAtParam obj (1+ n))
  159.       (vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT enp))
  160.         (vla-AddVertex obj 1 (GXL-AX:2DPOINT enp))
  161.         )
  162.       (vla-SetBulge obj n bulge)
  163.       )
  164.     )
  165.  
  166.   (defun tk2 (E R CLOCK / OBJ POLYCLOCK I P1 P2 P3 ARCDATA PT BULGE FLAG
  167.                 N)
  168.     (setq obj (vlax-ename->vla-object e))
  169.     (vla-put-Closed obj :vlax-true)
  170.     (setq polyClock (not (gxl-clock e)))
  171.     (setq i 0)
  172.       (setq p1 (vlax-curve-getPointAtParam obj i)
  173.             p2 (vlax-curve-getPointAtParam obj (setq i (1+ i)))
  174.             p3 (vlax-curve-getPointAtParam obj (1+ i))
  175.             )
  176.       (if (null p3) (setq p3 (vlax-curve-getPointAtParam obj 1)))
  177.       (cond
  178.         (polyClock
  179.          (cond
  180.            (clock
  181.            
  182.             (setq arcdata (cons (list (polar p2 (angle p2 p3) r) -1 nil) arcdata))
  183.             )
  184.            (t
  185.             (setq arcdata (cons (list (polar p2 (angle p2 p1) r) -1 t) arcdata))
  186.             )
  187.            )
  188.          )
  189.         (t
  190.          (cond
  191.            (clock
  192.             (setq arcdata (cons (list (polar p2 (angle p2 p1) r) 1 t) arcdata))
  193.             )
  194.            (t
  195.             (setq arcdata (cons (list (polar p2 (angle p2 p3) r) 1 nil) arcdata))
  196.             )
  197.            )
  198.          )
  199.         )
  200.       )
  201.      (setq  arcdata (reverse arcdata))
  202.     (foreach data arcdata
  203.       (setq pt (car data)
  204.             bulge (cadr data)
  205.             flag (caddr data)
  206.             )
  207.                      obj
  208.                      (vlax-curve-getclosestpointto obj pt)
  209.                      )
  210.                    )
  211.             )
  212.       (if (vlax-curve-getPointAtParam obj (1+ n))
  213.         (progn
  214.          (vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT pt))
  215.          (if flag
  216.            (vla-SetBulge obj (1+ n) bulge)
  217.            (vla-SetBulge obj n bulge)
  218.            )
  219.          )
  220.         (progn
  221.          (vla-AddVertex obj 1 (GXL-AX:2DPOINT pt))
  222.          (if flag
  223.            (vla-SetBulge obj 1 bulge)
  224.            (vla-SetBulge obj 0 bulge)
  225.            )
  226.          )
  227.         )
  228.       )
  229.       )
  230.   (initget "1 2 3")
  231.   (if (null
  232.         (setq kd (getkword "\n[standard(1)/Clockwise(2)/counterclockwise(3)]<1>"))
  233.         )
  234.     (setq kd "1")
  235.     )
  236.   (cond
  237.     ((= "1" kd)
  238.      (if (null (setq a (getreal "\nescape deep<0.1>:")))
  239.        (setq a 0.1)
  240.        )
  241.      (if (null (setq r (getreal "\nescape Radius<0.4>:")))
  242.        (setq r 0.4)
  243.        )
  244.      (while (setq ss (ssget '((0 . "lwpolyline"))))
  245.        (repeat (setq n (sslength ss))
  246.          (setq e (ssname ss (setq n (1- n))))
  247.          (tk1 e a r)
  248.          )
  249.        )
  250.      )
  251.     (t
  252.      (if (null (setq r (getreal "\nescape Radius<0.4>:")))
  253.        (setq r 0.4)
  254.        )
  255.      (while (setq ss (ssget '((0 . "*polyline"))))
  256.        (repeat (setq n (sslength ss))
  257.          (setq e (ssname ss (setq n (1- n))))
  258.          (tk2 e  r (= "2" kd))
  259.          )
  260.        )
  261.      )
  262.     )
  263.   (princ)
  264.   )
« Last Edit: February 01, 2014, 11:42:38 PM by CAB »

ymg

  • Swamp Rat
  • Posts: 725
Re: Seek help:Don't make slug holes in the filleted or chamfered corner
« Reply #1 on: February 02, 2014, 12:41:07 AM »
2e4elite,

What is a slug hole ????

Maybe post an example of what you are trying to achieve.

ymg

2e4lite

  • Guest
Re: Seek help:Don't make slug holes in the filleted or chamfered corner
« Reply #2 on: February 02, 2014, 03:40:34 AM »
ymg,

The slug holes (also called Escape holes) . Attached Images will illustrate it better.

2e4elite


« Last Edit: February 02, 2014, 03:45:42 AM by 2e4lite »

ribarm

  • Water Moccasin
  • Posts: 2126
  • Marko Ribar, architect
Re: Seek help:Don't make slug holes in the filleted or chamfered corner
« Reply #3 on: February 02, 2014, 04:02:29 AM »
How do you determine filleted or chamfered corner?... According to my tests the code won't error in any case of polylines, so what do you propose that ymg should do ab this; I just don't see any problem... Only thing you should consider is that curved arcs segments of polyline will be afterwards converted into straight segements with arcs at corners as should...

[EDIT note : Only thing I would suggest is cosmetic nature - better formatting and prompts specifications and also you had mistake at the end in (while) loops - I've added (while (not ss) (setq ss (ssget ...))) so that at the end of routine doesn't ask again for "Select Objects" as now does...]

Code: [Select]
(defun c:esc (/          TK1        TK2        KD         A
              R          SS         N          E
              IntersLineCircle      gxl-Ax:2DPoint        gxl-clock
             )

  (vl-load-com)

  (defun IntersLineCircle (p q c r / a d n s)
    (setq n (mapcar '- q p)
          p (trans p 0 n)
          c (trans c 0 n)
          a (list (car p) (cadr p) (caddr c))
    )
    (cond
      ((equal r (setq d (distance c a)))
       (list (trans a n 0))
      )
      ((< d r)
       (setq s (sqrt (- (* r r) (* d d))))
       (list
         (trans (list (car p) (cadr p) (- (caddr c) s)) n 0)
         (trans (list (car p) (cadr p) (+ (caddr c) s)) n 0)
       )
      )
    )
  )
  (defun gxl-Ax:2DPoint (pt)
    (vlax-make-variant
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbdouble '(0 . 1))
        (list (car pt) (cadr pt))
      )
    )
  )
  (defun gxl-clock (PLIST / LW MINP MAXP LST)
    (cond
      ((= 'LIST (type plist))
       (not
         (minusp
           (apply '+
                  (mapcar
                    (function
                      (lambda (a b)
                        (- (* (car b) (cadr a)) (* (car a) (cadr b)))
                      )
                    )
                    plist
                    (cons (last plist) plist)
                  )
           )
         )
       )
      )
      (t
       (if (= 'ename (type plist))
         (setq lw (vlax-ename->vla-object plist))
         (if (= 'VLA-OBJECT (type plist))
           (setq lw plist)
         )
       )
       (vla-GetBoundingBox lw 'MinP 'MaxP)
       (setq
         minp (vlax-safearray->list minp)
         MaxP (vlax-safearray->list MaxP)
         lst  (mapcar
                (function
                  (lambda (x)
                    (vlax-curve-getParamAtPoint
                      lw
                      (vlax-curve-getClosestPointTo lw x)
                    )
                  )
                )
                (list minp
                      (list (car MaxP) (cadr minp))
                      MaxP
                      (list (car minp) (cadr MaxP))
                )
              )
       )
       (if (or
             (<= (car lst) (cadr lst) (caddr lst) (cadddr lst))
             (<= (cadr lst) (caddr lst) (cadddr lst) (car lst))
             (<= (caddr lst) (cadddr lst) (car lst) (cadr lst))
             (<= (cadddr lst) (car lst) (cadr lst) (caddr lst))
           )
         t
       )
      )
    )
  )

  (defun tk1 (E     A     R     /     N     EL    I     P1    P2
              P3    CLOCKWISEP  MIDANG      CP    MRP   STP   ENP
              MP    BULGE ARCDATA     OBJ   A1    A2
             )
    (setq obj (vlax-ename->vla-object e))
    (vla-put-Closed obj :vlax-true)
    (setq n (fix (vlax-curve-getEndParam obj)))
                                        ;(if (/= 1 (logand (cdr (assoc 70 el)) 1)) (setq n (- n 2)))
    (setq i 0)
    (repeat n
      (setq p1 (vlax-curve-getPointAtParam e i)
            p2 (vlax-curve-getPointAtParam e (setq i (1+ i)))
            p3 (vlax-curve-getPointAtParam e (1+ i))
      )
      (if (null p3)
        (setq p3 (vlax-curve-getPointAtParam e 1))
      )
      (setq a1 (angle p2 p1)
            a2 (angle p2 p3)
      )
      (setq clockwisep
             (<
               (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
               (* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
             )
      )
      (if (< a1 a2)
        (setq a1 (+ a1 pi pi))
      )
      (setq midang (* 0.5 (+ a1 a2)))
      (if clockwisep
        (setq cp  (polar p2 midang (- a r))
              mrp (polar p2 midang a)
        )
        (setq cp  (polar p2 midang (- r a))
              mrp (polar p2 midang (- a))
        )
      )
      (setq stp (car (vl-remove-if-not
                       '(lambda (x)
                          (equal (+ (distance p1 x) (distance p2 x))
                                 (distance p1 p2)
                                 1e-6
                          )
                        )
                       (IntersLineCircle p2 p1 cp r)
                     )
                )
      )
      (setq enp (car (vl-remove-if-not
                       '(lambda (x)
                          (equal (+ (distance p3 x) (distance p2 x))
                                 (distance p3 p2)
                                 1e-6
                          )
                        )
                       (IntersLineCircle p2 p3 cp r)
                     )
                )
      )
      (setq mp (mapcar '* '(0.5 0.5 0.5) (MAPCAR '+ stp enp)))
      (setq bulge (/ (distance mrp mp) (distance mp stp)))
      (if clockwisep
        (setq bulge (- bulge))
      )
      (setq arcdata (cons (list stp enp bulge) arcdata))
    )
    (setq arcdata (reverse arcdata))
    (foreach data arcdata
      (setq stp   (car data)
            enp   (cadr data)
            bulge (caddr data)
      )
      (setq n (fix (vlax-curve-getParamAtPoint
                     obj
                     (vlax-curve-getclosestpointto obj enp)
                   )
              )
      )
      (vla-put-coordinate obj n (GXL-AX:2DPOINT stp))
      (if (vlax-curve-getPointAtParam obj (1+ n))
        (vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT enp))
        (vla-AddVertex obj 1 (GXL-AX:2DPOINT enp))
      )
      (vla-SetBulge obj n bulge)
    )
  )

  (defun tk2 (E R CLOCK / OBJ POLYCLOCK I P1 P2 P3 ARCDATA PT BULGE FLAG
              N)
    (setq obj (vlax-ename->vla-object e))
    (vla-put-Closed obj :vlax-true)
    (setq polyClock (not (gxl-clock e)))
    (setq i 0)
    (repeat (fix (vlax-curve-getEndParam obj))
      (setq p1 (vlax-curve-getPointAtParam obj i)
            p2 (vlax-curve-getPointAtParam obj (setq i (1+ i)))
            p3 (vlax-curve-getPointAtParam obj (1+ i))
      )
      (if (null p3)
        (setq p3 (vlax-curve-getPointAtParam obj 1))
      )
      (cond
        (polyClock
         (cond
           (clock

            (setq
              arcdata (cons (list (polar p2 (angle p2 p3) r) -1 nil)
                            arcdata
                      )
            )
           )
           (t
            (setq arcdata (cons (list (polar p2 (angle p2 p1) r) -1 t)
                                arcdata
                          )
            )
           )
         )
        )
        (t
         (cond
           (clock
            (setq arcdata (cons (list (polar p2 (angle p2 p1) r) 1 t)
                                arcdata
                          )
            )
           )
           (t
            (setq
              arcdata (cons (list (polar p2 (angle p2 p3) r) 1 nil)
                            arcdata
                      )
            )
           )
         )
        )
      )
    )
    (setq arcdata (reverse arcdata))
    (foreach data arcdata
      (setq pt    (car data)
            bulge (cadr data)
            flag  (caddr data)
      )
      (setq n (fix (vlax-curve-getParamAtPoint
                     obj
                     (vlax-curve-getclosestpointto obj pt)
                   )
              )
      )
      (if (vlax-curve-getPointAtParam obj (1+ n))
        (progn
          (vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT pt))
          (if flag
            (vla-SetBulge obj (1+ n) bulge)
            (vla-SetBulge obj n bulge)
          )
        )
        (progn
          (vla-AddVertex obj 1 (GXL-AX:2DPOINT pt))
          (if flag
            (vla-SetBulge obj 1 bulge)
            (vla-SetBulge obj 0 bulge)
          )
        )
      )
    )
  )
  (initget "1 2 3")
  (if (null
        (setq kd (getkword
                   "\n[Standard(1)/ClockWise(2)/CounterClockWise(3)] <1> : "
                 )
        )
      )
    (setq kd "1")
  )
  (cond
    ((= "1" kd)
     (if (null (setq a (getreal "\nEscape Deep <0.1> : ")))
       (setq a 0.1)
     )
     (if (null (setq r (getreal "\nEscape Radius <0.4> : ")))
       (setq r 0.4)
     )
     (while (not ss)
       (setq ss (ssget '((0 . "LWPOLYLINE"))))
       (repeat (setq n (sslength ss))
         (setq e (ssname ss (setq n (1- n))))
         (tk1 e a r)
       )
     )
    )
    (t
     (if (null (setq r (getreal "\nEscape Radius <0.4> : ")))
       (setq r 0.4)
     )
     (while (not ss)
       (setq ss (ssget '((0 . "LWPOLYLINE"))))
       (repeat (setq n (sslength ss))
         (setq e (ssname ss (setq n (1- n))))
         (tk2 e r (= "2" kd))
       )
     )
    )
  )
  (princ)
)
« Last Edit: February 02, 2014, 05:24:15 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ymg

  • Swamp Rat
  • Posts: 725
Re: Seek help:Don't make slug holes in the filleted or chamfered corner
« Reply #4 on: February 02, 2014, 05:23:08 AM »
Marko,

As you said, the problem is you would need to define what is a fillet and/or chamfer.

The rest of the routine seems to do what it should.  It does seem strange though that arc
are converted to straight segments.

ymg

ribarm

  • Water Moccasin
  • Posts: 2126
  • Marko Ribar, architect
Re: Seek help:Don't make slug holes in the filleted or chamfered corner
« Reply #5 on: February 02, 2014, 05:27:00 AM »
It does seem strange though that arc are converted to straight segments.

But that's double bulge specifications, that's why it's too difficult to realize it correctly...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

flyfox1047

  • Guest
Re: Seek help:Don't make slug holes in the filleted or chamfered corner
« Reply #6 on: February 03, 2014, 09:29:37 AM »
try this: [from here:  http://www.cadtutor.net/forum/showthread.php?83980-Help-me-take-a-look-at-this-lisp-thanks! ]
Code: [Select]
;; Author:Gu_xl 2013.05.08;;update: 2014.01.06
(defun c:tt (/ TK1 TK2 KD A R SS N E)
  ;;standard calculate
  (defun tk1 (E A      R      /      N      EL     I      P1     P2
                P3     CLOCKWISEP    MIDANG CP     MRP    STP    ENP
                MP     BULGE  ARCDATA       OBJ A1 A2 k
                )
    (setq obj (vlax-ename->vla-object e))
    (if (vlax-curve-isClosed obj)
      (progn
        (setq i 0)
        (setq n (fix (vlax-curve-getEndParam obj)))
        )
      (progn
        (setq i 0)
        (setq n (1- (fix (vlax-curve-getEndParam obj)) ))
        )
      )

    (repeat n
      (setq p1 (vlax-curve-getPointAtParam e i)
            p2 (vlax-curve-getPointAtParam e (setq i (1+ i)))
            p3 (vlax-curve-getPointAtParam e (1+ i))
            )
      (if (and
            (vlax-curve-isClosed obj)
            (equal i (vlax-curve-getEndParam obj) 1e-6)
            )
        (setq k 0)
        (setq k i)
        )
      (if (and
            (equal 0 (vla-GetBulge obj (1- i)) 1e-6)
            (equal 0 (vla-GetBulge obj k) 1e-6)
            )
        (progn
      (if (null p3) (setq p3 (vlax-curve-getPointAtParam e 1)))
      (setq a1 (angle p2 p1)
            a2 (angle p2 p3)
            )
      (setq clockwisep
             (<
               (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
               (* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
               )
            )
      (if (< a1 a2) (setq a1 (+ a1 pi pi)))
      (setq midang (* 0.5 (+ a1 a2)))
      (if clockwisep
        (setq cp (polar p2 midang (- a r))
              mrp (polar p2 midang a)
              )
        (setq cp (polar p2 midang (- r a))
              mrp (polar p2 midang (- a))
              )
        )
      (setq stp (car (vl-remove-if-not
                       '(lambda (x)
                          (equal (+ (distance p1 x) (distance p2 x))
                                 (distance p1 p2)
                                 1e-6
                                 )
                          )
                       (IntersLineCircle p2 p1 cp r)
                       )
                     )
            ) ;_ Arc start
      (setq enp (car (vl-remove-if-not
                       '(lambda (x)
                          (equal (+ (distance p3 x) (distance p2 x))
                                 (distance p3 p2)
                                 1e-6
                                 )
                          )
                       (IntersLineCircle p2 p3 cp r)
                       )
                     )
            ) ;_ Arc end
      (setq mp (mapcar '* '(0.5 0.5 0.5) (MAPCAR '+ stp enp)))
      (setq bulge (/ (distance mrp mp) (distance mp stp))) ;_ Bowstring ratio
      (if clockwisep (setq bulge (- bulge)))
      (setq arcdata (cons (list stp enp bulge) arcdata))
      )
        )
      )
    (setq  arcdata (reverse arcdata))
    (foreach data arcdata
      (setq stp (car data)
            enp (cadr data)
            bulge (caddr data)
            )
      (setq n (fix (vlax-curve-getParamAtPoint
                     obj
                     (vlax-curve-getclosestpointto obj enp)
                     )
                   )
            )
      (vla-put-coordinate obj n (GXL-AX:2DPOINT stp))
      (if (vlax-curve-getPointAtParam obj (1+ n))
      (vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT enp))
        (vla-AddVertex obj 1 (GXL-AX:2DPOINT enp))
        )
      (vla-SetBulge obj n bulge)
      )
    )
  ;;clockwise
  (defun tk2 (E R CLOCK / OBJ POLYCLOCK I P1 P2 P3 ARCDATA PT BULGE FLAG
                N k)
    (setq obj (vlax-ename->vla-object e))
    (setq polyClock (not (gxl-clock e)))
    (setq i 0)
    (if (vlax-curve-isClosed obj)
      (progn
        (setq i 0)
        (setq n (fix (vlax-curve-getEndParam obj)))
        )
      (progn
        (setq i 0)
        (setq n (1- (fix (vlax-curve-getEndParam obj))))
        )
      )
    (repeat n
      (setq p1 (vlax-curve-getPointAtParam obj i)
            p2 (vlax-curve-getPointAtParam obj (setq i (1+ i)))
            p3 (vlax-curve-getPointAtParam obj (1+ i))
            )
      (if (and
            (vlax-curve-isClosed obj)
            (equal i (vlax-curve-getEndParam obj) 1e-6)
            )
        (setq k 0)
        (setq k i)
        )
      (if (and
            (equal 0 (vla-GetBulge obj (1- i)) 1e-6)
            (equal 0 (vla-GetBulge obj k) 1e-6)
            )
        (progn
      (if (null p3) (setq p3 (vlax-curve-getPointAtParam obj 1)))
      (cond
        (polyClock ;_ Curve clockwise
         (cond
           (clock ;_

            (setq arcdata (cons (list (polar p2 (angle p2 p3) r) -1 nil) arcdata))
            )
           (t ;_
            (setq arcdata (cons (list (polar p2 (angle p2 p1) r) -1 t) arcdata))
            )
           )
         )
        (t ;_ Curve counterclockwise
         (cond
           (clock ;_
            (setq arcdata (cons (list (polar p2 (angle p2 p1) r) 1 t) arcdata))
            )
           (t ;_
            (setq arcdata (cons (list (polar p2 (angle p2 p3) r) 1 nil) arcdata))
            )
           )
         )
        )
      )
    )
      )
     (setq  arcdata (reverse arcdata))
    (foreach data arcdata
      (setq pt (car data)
            bulge (cadr data)
            flag (caddr data)
            )
      (setq n (fix (vlax-curve-getParamAtPoint
                     obj
                     (vlax-curve-getclosestpointto obj pt)
                     )
                   )
            )
      (if (vlax-curve-getPointAtParam obj (1+ n))
        (progn
         (vla-AddVertex obj (1+ n) (GXL-AX:2DPOINT pt))
         (if flag
           (vla-SetBulge obj (1+ n) bulge)
           (vla-SetBulge obj n bulge)
           )
         )
        (progn
         (vla-AddVertex obj 1 (GXL-AX:2DPOINT pt))
         (if flag
           (vla-SetBulge obj 1 bulge)
           (vla-SetBulge obj 0 bulge)
           )
         )
        )
      )
      )
  (initget "1 2 3")
  (if (null
        (setq kd (getkword "\n[standard(1)/clockwise(2)/counterclockwise(3)]<1>"))
        )
    (setq kd "1")
    )
  (cond
    ((= "1" kd)
     (if (null (setq a (getreal "\nMagnitude<5.0>:")))
       (setq a 5.0)
       )
     (if (null (setq r (getreal "\nAperture radius<10.0>:")))
       (setq r 10.0)
       )
     (while (setq ss (ssget '((0 . "lwpolyline"))))
       (repeat (setq n (sslength ss))
         (setq e (ssname ss (setq n (1- n))))
         (tk1 e a r) ;_ trim
         )
       )
     )
    (t
     (if (null (setq r (getreal "\nAperture radius<10.0>:")))
       (setq r 10.0)
       )
     (while (setq ss (ssget '((0 . "*polyline"))))
       (repeat (setq n (sslength ss))
         (setq e (ssname ss (setq n (1- n))))
         (tk2 e  r (= "2" kd)) ;_ trim
         )
       )
     )
    )
  (princ)
  )
;;*******************A custom function****************************
;; Line-Circle Intersection - Lee Mac
(defun IntersLineCircle ( p q c r / a d n s )
  (setq n (mapcar '- q p)
        p (trans p 0 n)
        c (trans c 0 n)
        a (list (car p) (cadr p) (caddr c))
  )
  (cond
    ( (equal r (setq d (distance c a)))
      (list (trans a n 0))
    )
    ( (< d r)
      (setq s (sqrt (- (* r r) (* d d))))
      (list
        (trans (list (car p) (cadr p) (- (caddr c) s)) n 0)
        (trans (list (car p) (cadr p) (+ (caddr c) s)) n 0)
      )
    )
  )
)
;;
(defun gxl-Ax:2DPoint (pt)
  (vlax-make-variant
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbdouble '(0 . 1))
      (list (car pt) (cadr pt))
    )
  )
)
;;
(defun gxl-clock  (PLIST / LW MINP MAXP LST)
  (cond        ((= 'LIST (type plist))
          (not
            (minusp
              (apply '+
                     (mapcar
                       (function
                         (lambda (a b)
                           (- (* (car b) (cadr a)) (* (car a) (cadr b)))
                         )
                       )
                       plist
                       (cons (last plist) plist)
                     )
              )
            )
          )
        )
        (t
         (if (= 'ename (type plist))
           (setq lw (vlax-ename->vla-object plist))
           (if (= 'VLA-OBJECT (type plist))
             (setq lw plist)
             )
           )
         (vla-GetBoundingBox lw 'MinP 'MaxP)
         (setq
           minp        (vlax-safearray->list minp)
           MaxP        (vlax-safearray->list MaxP)
           lst        (mapcar
                  (function
                    (lambda (x)
                      (vlax-curve-getParamAtPoint
                        lw
                        (vlax-curve-getClosestPointTo lw x)
                        )
                      )
                    )
                  (list        minp
                        (list (car MaxP) (cadr minp))
                        MaxP
                        (list (car minp) (cadr MaxP))
                        )
                  )
           )
         (if (or
               (<= (car lst) (cadr lst) (caddr lst) (cadddr lst))
               (<= (cadr lst) (caddr lst) (cadddr lst) (car lst))
               (<= (caddr lst) (cadddr lst) (car lst) (cadr lst))
               (<= (cadddr lst) (car lst) (cadr lst) (caddr lst))
               )
           t
           )
         )
        )

  )

« Last Edit: February 03, 2014, 09:38:58 AM by flyfox1047 »