Jump to content

connected polylines corners


martinle

Recommended Posts

Hello

Please help!

I can not lisp.

Seeking a way with a lisp to connect the corners of a closed polyline.

These polylines are always so similar to the example.

There are very many such lines and it would be great if you could solve with a lisp.

Thank you!

Martin

connected polylines corners.jpg

Link to comment
Share on other sites

Hi Martin

 

Try this, but be aware that it will fail if there are duplicate points or if any partial distance is shorter that the "offset" distance.

(defun connect (e / _point d d1 l p1 p2 a b n i)
 (setq _point vlax-curve-getpointatparam
       d (vlax-curve-getdistatparam e (setq n (fix (+ 0.1 (vlax-curve-getendparam e))))))
 (repeat (setq i (1+ n))
   (setq l (cons (setq p1 (_point e (setq i (1- i)))) l))
   (if
     (setq p2 (cadr l))
     (if
       (and
         (< (setq d1 (distance p1 p2)) d)
         (not (zerop d1))
       )
       (setq
         d d1
         a (rem (1+ i) n)
         b i
         )
       )
     )
   )
 (mapcar 'set '(a b) (list (max a b) (min a b)))
 (while
   (progn
     (setq a (rem (1+ a) n))
     (setq b (rem (+ n (1- b)) n))
     (not (= (rem (1+ a) n) b))
   )
   (entmake
     (list
       '(0 . "LINE")
       (cons 10 (_point e a))
       (cons 11 (_point e b))
       )
     )
   )
 )

(defun c:test (/ ss i)
 (if
   (setq ss (ssget '((0 . "LWPOLYLINE"))))
   (repeat (setq i (sslength ss))
     (connect (ssname ss (setq i (1- i))))
     )
   )
 (princ)
 )

Link to comment
Share on other sites

Just in case you would like an alternative which does not use lisp, draw a polyline at the centre, give it a width, and turn Fill off. The effect is the same

WidePolyline-NoFill.PNG

Link to comment
Share on other sites

You're welcome Martin

 

Duplicate points bug removed

(defun connect (e / _point d d1 p1 p2 p11 p12 p21 p22 a b n i)
 (setq _point vlax-curve-getpointatparam
       d (vlax-curve-getdistatparam e
           (setq n (fix (+ 0.1 (vlax-curve-getendparam e))))
         )
       )
 (repeat (setq i (1+ n))
   (setq p1 (_point e (setq i (1- i))))
   (if p2
     (if
       (and
         (< (setq d1 (distance p1 p2)) d)
         (not (zerop d1))
       )
       (setq
         d d1
         a (rem (1+ i) n)
         b i
         )
       )
     )
   (setq p2 p1)
   )
 (if (zerop b) (mapcar 'set '(a b) (list b a)))
 (setq p11 (_point e a)
       p21 (_point e b)
       )
 (while
   (progn
     (while
       (equal p11 (setq p12 (_point e (setq a (rem (1+ a) n)))) 1e-
       )
     (while
       (equal p21 (setq p22 (_point e (setq b (rem (+ n (1- b)) n)))) 1e-
       )
     (not
       (or
         (= (abs (- a b)) 1)
         (= (abs (- a b)) n)
       )
     )
   )
   (entmake
     (list
       '(0 . "LINE")
       (cons 10 (setq p11 p12))
       (cons 11 (setq p21 p22))
       )
     )
   )
 )

(defun c:test (/ ss i)
 (if
   (setq ss (ssget '((0 . "LWPOLYLINE"))))
   (repeat (setq i (sslength ss))
     (connect (ssname ss (setq i (1- i))))
     )
   )
 (princ)
 )

Edited by Stefan BMR
Updated
Link to comment
Share on other sites

Hello Stefan,

 

One small thing is I have noticed.

There are drawn all the oblique connections.

But also a connection to the straight end of the polyline.

Would it still possible that you will not use it to create any line on the other is?

That would be great!

 

Many thanks!

 

Martin

Link to comment
Share on other sites

Nice solution Stefan :thumbsup:

 

Here's another way:

(defun c:test ( / a d e f i l n v x )
   (if (setq e (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
       (progn
           (setq l (entget (ssname e 0))
                 l (cons (assoc 10 (reverse l)) l)
                 f (lambda ( x ) (reverse (cdr x)))
                 d 1e308 n 0
           )
           (while (setq a (assoc 10 l))
               (and v (< (setq x (distance (cdr a) (car v))) d) (setq d x i n))
               (or (and v (equal (car v) (cdr a) 1e-3))
                   (setq v (cons (cdr a) v))
               )
               (setq l (cdr (member a l))
                     n (1+ n)
               )
           )
           (setq v (f v))
           (repeat i (setq v (reverse (cons (car v) (f v)))))
           (repeat (- (/ (length v) 2) 2)
               (entmake (list '(0 . "LINE") (cons 10 (car (setq v (f (f v))))) (cons 11 (last v))))
           )
       )
   )
   (princ)
)

Link to comment
Share on other sites

Thanks Lee

 

Your solution is nice and concise, as always.

Maybe Martin is pleased with both lisps and he might have a clean drawing, but we both fail to cover all the exceptions.

Try this polyline:

(entmakex 
'(
   (0 . "LWPOLYLINE")
   (100 . "AcDbEntity")
   (100 . "AcDbPolyline")
   (62 . 3)
   (90 . 12) (70 . 1)
   (10 5.0 5.0) (10 5.0 1.0)
   (10 2.0 1.0) (10 2.0 2.0)
   (10 2.0 2.0) (10 4.0 2.0)
   (10 4.0 4.0) (10 1.0 4.0)
   (10 1.0 0.0) (10 0.0 0.0)
   (10 0.0 5.0) (10 0.0 5.0)
 )
)

Link to comment
Share on other sites

Your solution is nice and concise, as always.

 

Thank you!

 

Maybe Martin is pleased with both lisps and he might have a clean drawing, but we both fail to cover all the exceptions.

Try this polyline:

 

Good catch - fixed:

([color=BLUE]defun[/color] c:test ( [color=BLUE]/[/color] a d e f i l n v x )
   ([color=BLUE]if[/color] ([color=BLUE]setq[/color] e ([color=BLUE]ssget[/color] [color=MAROON]"_+.:E:S"[/color] '((0 . [color=MAROON]"LWPOLYLINE"[/color]) (-4 . [color=MAROON]"&="[/color]) (70 . 1))))
       ([color=BLUE]progn[/color]
           ([color=BLUE]setq[/color] l ([color=BLUE]entget[/color] ([color=BLUE]ssname[/color] e 0))
                 l ([color=BLUE]cons[/color] ([color=BLUE]assoc[/color] 10 ([color=BLUE]reverse[/color] l)) l)
                 f ([color=BLUE]lambda[/color] ( x ) ([color=BLUE]reverse[/color] ([color=BLUE]cdr[/color] x)))
                 d 1e308 n 0
           )
           ([color=BLUE]while[/color] ([color=BLUE]setq[/color] a ([color=BLUE]assoc[/color] 10 l))
               ([color=BLUE]cond[/color]
                   (   ([color=BLUE]not[/color] v) ([color=BLUE]setq[/color] v ([color=BLUE]cons[/color] ([color=BLUE]cdr[/color] a) v)))
                   (   ([color=BLUE]equal[/color] ([color=BLUE]car[/color] v) ([color=BLUE]cdr[/color] a) 1e-3))
                   (   ([color=BLUE]<[/color] ([color=BLUE]setq[/color] x ([color=BLUE]distance[/color] ([color=BLUE]cdr[/color] a) ([color=BLUE]car[/color] v))) d) ([color=BLUE]setq[/color] d x i n v ([color=BLUE]cons[/color] ([color=BLUE]cdr[/color] a) v)))
                   (   ([color=BLUE]setq[/color] v ([color=BLUE]cons[/color] ([color=BLUE]cdr[/color] a) v)))
               )
               ([color=BLUE]setq[/color] l ([color=BLUE]cdr[/color] ([color=BLUE]member[/color] a l))
                     n ([color=BLUE]1+[/color] n)
               )
           )
           ([color=BLUE]setq[/color] v (f v))
           ([color=BLUE]repeat[/color] i ([color=BLUE]setq[/color] v ([color=BLUE]reverse[/color] ([color=BLUE]cons[/color] ([color=BLUE]car[/color] v) (f v)))))
           ([color=BLUE]repeat[/color] ([color=BLUE]-[/color] ([color=BLUE]/[/color] ([color=BLUE]length[/color] v) 2) 2)
               ([color=BLUE]entmake[/color] ([color=BLUE]list[/color] '(0 . [color=MAROON]"LINE"[/color]) ([color=BLUE]cons[/color] 10 ([color=BLUE]car[/color] ([color=BLUE]setq[/color] v (f (f v))))) ([color=BLUE]cons[/color] 11 ([color=BLUE]last[/color] v))))
           )
       )
   )
   ([color=BLUE]princ[/color])
)

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...