Jump to content

Draw polyline along with 2 or more adjacent closed polylines

chvnprasad

By chvnprasad
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

  • Replies 48
  • Created
  • Last Reply

Top Posters In This Topic

  • marko_ribar

    35

  • pBe

    4

  • chvnprasad

    4

  • Lee Mac

    1

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

marko_ribar
marko_ribar

And also have searched for adding and removing vertex to and from polyline... It works also for LWPOLYLINE and old heavy POLYLINE...   (defun c:plav ( / add_vtx pt pl flag ) (vl-load-com)

marko_ribar
marko_ribar

Since I've test my codes and they didn't fail in any situations, no matter what orientation of plines and UCS, if they are connected 2 by 2 and are in the same plane, PlPath.lsp won't fail... So, I de

marko_ribar
marko_ribar

My latest addition to PLINETOOLS archive... ( 3 missing lisps ... )   They'll divide LWPOLYLINE with equal distances, but make divisions center viewing from each segment of polyline (ending segments

Posted Images

marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

Two more lisps - or you can load them both...

 

(defun c:lwint2bulge ( / *error* clean_poly mid clockwise-p *adoc* osm p lw p1 p2 lwx dxf10 a c1 c2 r1 r2 c dxf10n pn r b gr )

 (vl-load-com)

 (defun *error* ( m )
   (if osm
     (setvar 'osmode osm)
   )
   (clean_poly lw)
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (defun clean_poly ( ent / trunc e_lst p_lst )

   (defun trunc ( expr lst )
     (if (and lst (not (equal (car lst) expr 1e-6)))
       (cons (car lst) (trunc expr (cdr lst)))
     )
   )

   (setq e_lst (entget ent))
   (if (= "LWPOLYLINE" (cdr (assoc 0 e_lst)))
     (progn
       (setq p_lst 
                   (vl-remove-if-not 
                    '(lambda (x)
                       (or (= (car x) 10)
                           (= (car x) 40)
                           (= (car x) 41)
                           (= (car x) 42)
                       )
                     )
                     e_lst
                   )
             e_lst 
                   (vl-remove-if
                    '(lambda (x)
                       (member x p_lst)
                     )
                     e_lst
                   )
       )
       (if (= 1 (logand (cdr (assoc 70 e_lst)) 1))
         (while (equal (car p_lst) (assoc 10 (reverse p_lst)))
           (setq p_lst (reverse (cdr (member (assoc 10 (reverse p_lst)) (reverse p_lst)))))
         )
       )
       (while p_lst
         (setq e_lst (append e_lst (trunc (assoc 10 (cdr p_lst)) p_lst))
               p_lst (member (assoc 10 (cdr p_lst)) (cdr p_lst))
         )
       )
       (entmod e_lst)
     )
   )
   (princ)
 )

 (defun mid ( p1 p2 )
   (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
 )

 (defun clockwise-p ( p1 p p2 )
   (minusp (- (* (car (mapcar '- p p1)) (cadr (mapcar '- p p2))) (* (cadr (mapcar '- p p1)) (car (mapcar '- p p2)))))
 )

 (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
 (setq osm (getvar 'osmode))
 (setvar 'osmode 1)
 (setq p (getpoint "\nPick intersection vertex on LWPOLYLINE other than start/end vertex..."))
 (setq lw (ssname (ssget "_C" p p '((0 . "LWPOLYLINE"))) 0))
 (setq p1 (vlax-curve-getpointatparam lw (1- (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (trans p 1 0))))))
 (setq p2 (vlax-curve-getpointatparam lw (1+ (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (trans p 1 0))))))
 (setq lwx (entget lw))
 (setq dxf10 (cons 10 (mapcar '+ '(0.0 0.0) (trans p 1 lw))))
 (setq a (angle (trans p 1 lw) (mid (polar (trans p 1 lw) (angle (trans p 1 lw) (trans p1 0 lw)) 1.0) (polar (trans p 1 lw) (angle (trans p 1 lw) (trans p2 0 lw)) 1.0))))
 (setq c1 (inters (trans p1 0 lw) (polar (trans p1 0 lw) (+ (angle (trans p 1 lw) (trans p1 0 lw)) (* 0.5 pi)) 1.0) (trans p 1 lw) (polar (trans p 1 lw) a 1.0) nil))
 (setq c2 (inters (trans p2 0 lw) (polar (trans p2 0 lw) (+ (angle (trans p 1 lw) (trans p2 0 lw)) (* 0.5 pi)) 1.0) (trans p 1 lw) (polar (trans p 1 lw) a 1.0) nil))
 (setq r1 (distance c1 (trans p1 0 lw)))
 (setq r2 (distance c2 (trans p2 0 lw)))
 (if (< r1 r2)
   (setq c c1)
   (setq c c2)
 )
 (setq dxf10n (cons 10 (mapcar '+ '(0.0 0.0) (trans (setq pn (trans (polar (trans p 1 lw) (angle (trans p 1 lw) (trans (if (equal c1 c 1e-6) p2 p1) 0 lw)) (if (equal c1 c 1e-6) (distance (trans p 1 lw) (trans p1 0 lw)) (distance (trans p 1 lw) (trans p2 0 lw)))) lw 0)) 0 lw))))
 (setq lwx (subst dxf10n (car (vl-member-if '(lambda ( x ) (equal x dxf10 1e-6)) lwx)) lwx))
 (if (equal (distance (trans p1 0 lw) (trans p 1 lw)) (+ (distance (trans p1 0 lw) (trans pn 0 lw)) (distance (trans pn 0 lw) (trans p 1 lw))) 1e-6)
   (progn
     (setq r (distance c (trans p2 0 lw)))
     (entupd (cdr (assoc -1 (entmod lwx))))
     (prompt "\nMove mouse around center of view left/right or up/down to choose type of bulge...")
     (while (= 5 (car (setq gr (grread t))))
       (if (> (* (- (car (getvar 'viewctr)) (caadr gr)) (- (cadr (getvar 'viewctr)) (cadadr gr))) 0.0)
         (progn
           (setq b (/ (sin (/ (rem (+ pi pi (- (angle c (trans pn 0 lw)) (angle c (trans p2 0 lw)))) (+ pi pi)) 4.0)) (cos (/ (rem (+ pi pi (- (angle c (trans pn 0 lw)) (angle c (trans p2 0 lw)))) (+ pi pi)) 4.0))))
           (if (not (clockwise-p (trans pn 0 lw) c (trans p2 0 lw)))
             (if (> (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
             (if (< (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
           )
           (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw pn) b)
         )
         (progn
           (setq b (/ (sin (/ (- (* 2.0 pi) (rem (+ pi pi (- (angle c (trans pn 0 lw)) (angle c (trans p2 0 lw)))) (+ pi pi))) 4.0)) (cos (/ (- (* 2.0 pi) (rem (+ pi pi (- (angle c (trans pn 0 lw)) (angle c (trans p2 0 lw)))) (+ pi pi))) 4.0))))
           (if (not (clockwise-p (trans pn 0 lw) c (trans p2 0 lw)))
             (if (> (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
             (if (< (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
           )
           (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw pn) b)
         )
       )
     )
   )
   (progn
     (setq r (distance c (trans p1 0 lw)))
     (entupd (cdr (assoc -1 (entmod lwx))))
     (prompt "\nMove mouse around center of view left/right or up/down to choose type of bulge...")
     (while (= 5 (car (setq gr (grread t))))
       (if (> (* (- (car (getvar 'viewctr)) (caadr gr)) (- (cadr (getvar 'viewctr)) (cadadr gr))) 0.0)
         (progn
           (setq b (/ (sin (/ (rem (+ pi pi (- (angle c (trans p1 0 lw)) (angle c (trans pn 0 lw)))) (+ pi pi)) 4.0)) (cos (/ (rem (+ pi pi (- (angle c (trans p1 0 lw)) (angle c (trans pn 0 lw)))) (+ pi pi)) 4.0))))
           (if (not (clockwise-p (trans p1 0 lw) c (trans pn 0 lw)))
             (if (> (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
             (if (< (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
           )
           (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw p1) b)
         )
         (progn
           (setq b (/ (sin (/ (- (* 2.0 pi) (rem (+ pi pi (- (angle c (trans p1 0 lw)) (angle c (trans pn 0 lw)))) (+ pi pi))) 4.0)) (cos (/ (- (* 2.0 pi) (rem (+ pi pi (- (angle c (trans p1 0 lw)) (angle c (trans pn 0 lw)))) (+ pi pi))) 4.0))))
           (if (not (clockwise-p (trans p1 0 lw) c (trans pn 0 lw)))
             (if (> (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
             (if (< (abs b) 1.0)
               (setq b (- (abs b)))
               (setq b (abs b))
             )
           )
           (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw p1) b)
         )
       )
     )
   )
 )
 (*error* nil)
)

(defun c:lwbulge2int ( / *error* clean_poly add_vtx *adoc* osm p lw p1 p2 lwx b v1 v2 pn dxf10 dxf10n )

 (vl-load-com)

 (defun *error* ( m )
   (if osm
     (setvar 'osmode osm)
   )
   (clean_poly lw)
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (defun clean_poly ( ent / trunc e_lst p_lst )

   (defun trunc ( expr lst )
     (if (and lst (not (equal (car lst) expr 1e-6)))
       (cons (car lst) (trunc expr (cdr lst)))
     )
   )

   (setq e_lst (entget ent))
   (if (= "LWPOLYLINE" (cdr (assoc 0 e_lst)))
     (progn
       (setq p_lst 
                   (vl-remove-if-not 
                    '(lambda (x)
                       (or (= (car x) 10)
                           (= (car x) 40)
                           (= (car x) 41)
                           (= (car x) 42)
                       )
                     )
                     e_lst
                   )
             e_lst 
                   (vl-remove-if
                    '(lambda (x)
                       (member x p_lst)
                     )
                     e_lst
                   )
       )
       (if (= 1 (logand (cdr (assoc 70 e_lst)) 1))
         (while (equal (car p_lst) (assoc 10 (reverse p_lst)))
           (setq p_lst (reverse (cdr (member (assoc 10 (reverse p_lst)) (reverse p_lst)))))
         )
       )
       (while p_lst
         (setq e_lst (append e_lst (trunc (assoc 10 (cdr p_lst)) p_lst))
               p_lst (member (assoc 10 (cdr p_lst)) (cdr p_lst))
         )
       )
       (entmod e_lst)
     )
   )
   (princ)
 )

 (defun add_vtx ( obj add_pt ent_name / bulg sw ew )
     (vla-GetWidth obj (fix add_pt) 'sw 'ew)
     (vla-addVertex
         obj
         (1+ (fix add_pt))
         (vlax-make-variant
             (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 1))
                     (list
                         (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                         (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                     )
             )
         )
     )
     (setq bulg (vla-GetBulge obj (fix add_pt)))
     (vla-SetBulge obj
         (fix add_pt)
         (/
             (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
             (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
         )
     )
     (vla-SetBulge obj
         (1+ (fix add_pt))
         (/
             (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
             (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
         )
     )
     (vla-SetWidth obj (fix add_pt) sw (+ sw (* (- ew sw) (- add_pt (fix add_pt)))))
     (vla-SetWidth obj (1+ (fix add_pt)) (+ sw (* (- ew sw) (- add_pt (fix add_pt)))) ew)
     (vla-update obj)
 )

 (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
 (setq osm (getvar 'osmode))
 (setvar 'osmode 512)
 (setq p (getpoint "\nPick bulged segment on LWPOLYLINE..."))
 (setq lw (ssname (ssget "_C" p p '((0 . "LWPOLYLINE"))) 0))
 (setq p1 (vlax-curve-getpointatparam lw (float (fix (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (trans p 1 0)))))))
 (setq p2 (vlax-curve-getpointatparam lw (float (1+ (fix (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (trans p 1 0))))))))
 (setq lwx (entget lw))
 (setq b (vla-getbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw p1)))
 (setq v1 (vlax-curve-getfirstderiv lw (vlax-curve-getparamatpoint lw p1)))
 (setq v2 (vlax-curve-getfirstderiv lw (- (vlax-curve-getparamatpoint lw p2) 1e-15)))
 (setq pn (inters p1 (mapcar '+ p1 v1) p2 (mapcar '+ p2 v2) nil))
 (vla-setbulge (vlax-ename->vla-object lw) (vlax-curve-getparamatpoint lw p1) 0.0)
 (add_vtx (vlax-ename->vla-object lw) (+ (vlax-curve-getparamatpoint lw p1) 0.5) lw)
 (vla-setbulge (vlax-ename->vla-object lw) (1- (vlax-curve-getparamatpoint lw p2)) 0.0)
 (setq lwx (entget lw))
 (setq dxf10 (assoc 10 (cdr (vl-member-if '(lambda ( x ) (equal x (cons 10 (mapcar '+ '(0.0 0.0) (trans p1 0 lw))) 1e-6)) lwx))))
 (setq dxf10n (cons 10 (mapcar '+ '(0.0 0.0) (trans pn 0 lw))))
 (entupd (cdr (assoc -1 (entmod (subst dxf10n dxf10 lwx)))))
 (setvar 'osmode osm)
 (*error* nil)
)

M.R.

Edited by marko_ribar
code changed...
Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted

Now when I study this topic again it seems that I forgot to include those :

http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/convert-polyline-line-segments-to-arc-segments/m-p/5814922/highlight/true#M335051

 

They also belong to PLINETOOLS although the kudos goes to Evgeniy Elpanov who introduced them in short variants working in WCS and then I revised them to be applicable in all situations...

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

This lisp is also possible to be inside PLINETOOLS... It is for offsetting LWPOLY segment with connection to boundary... Should work fine, just check for consistency of LWPOLY prior running routine... If there is some bug or lack please inform me...

 

Also I've found lack in Gille's (trunc) :

 (defun trunc ( expr lst )
   (if (and lst (not (equal (car lst) expr)))
     (cons (car lst) (trunc expr (cdr lst)))
   )
 )

Should be changed to something like this - allowing fuzz equality tolerance :

 (defun trunc ( expr lst )
   (if (and lst (not (equal (car lst) expr 1e-6)))
     (cons (car lst) (trunc expr (cdr lst)))
   )
 )

So please change this fix in every occurrence of (trunc) inside PLINETOOLS...

 

In attachment is lisp lwosegtd.lsp for offsetting segment...

lwosegtd.lsp

Edited by marko_ribar
Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

Reattached last posted lisp...

 

For those that downloaded it (2)... Add this fix at the end of lisp :

  

...
   )
 )
 (if (and lw1 (entget lw1) (not (equal lw1 (entlast))))
   (entdel lw1)
 )
 (if (and lw2 (entget lw2) (not (equal lw2 (entlast))))
   (entdel lw2)
 )
 (command "_.UCS" "_P")
 (*error* nil)
)
 

 

M.R. Sorry for this missed fix...

 

The most recent input ab PLINETOOLS is lwsdvts.lsp posted here :

https://www.theswamp.org/index.php?topic=58030.0

 

HTH.

M.R.

Edited by marko_ribar
  • Thanks 1
Link to comment
Share on other sites
  • 1 year later...
ajc Newbie

ajc

Posted
Posted

Hi Marko,

 

I've tried a few of your tools and think they are quite good.

Is there any brief description of each of the tools? I've bumped into a youtube video that shows the use of a few but not all lot them.

 

If you could update the code with a description of what it does and version number plus release date it'd help a lot. I know this may sound like a nuisance. I'm usually on the side of the tool developing and have to admit that this is quite useful for people and even myself to not loose track of what I'm doing. Plus it's easier for the author of the routine to actually summarize what it does.

 

Thank you.

Regards,

Link to comment
Share on other sites
aloy Proficient

aloy

Posted
Posted

This sort of algorithms are taught in secondary school levels in some countries (eg. UK's Cambridge IGSCE syllabus) and is called Decision Maths. I believe it is very useful for computer programmers.

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.

×
 Share
Go to topic listing
×
×
  • Create New...