Author Topic: Polyline and Circle to one polyline  (Read 3454 times)

0 Members and 1 Guest are viewing this topic.

Coder

  • Swamp Rat
  • Posts: 827
Polyline and Circle to one polyline
« on: February 19, 2017, 04:51:28 AM »
Hello guys.

I am working now with a new project that requires to deal with polylines all the time.

I would like to specify point on Polyline and create or reshape the polyline with a circle with diameter as variable like this:

Code: [Select]
(setq pot (getpoint "specify point on polyline to reshape:"))
(setq diamter (getreal "Diamter of circle please:"))

Thank you in advance.

Before and After

« Last Edit: February 19, 2017, 04:56:19 AM by Coder »

David Bethel

  • Swamp Rat
  • Posts: 656
Re: Polyline and Circle to one polyline
« Reply #1 on: February 19, 2017, 07:46:19 AM »
This doable but a complex routine. 

Basically having to insert vertices and bulges into an existing entity definition multiple times.

You would also need to specify the direction of the center in relation to the pline segment
R12 Dos - A2K

Coder

  • Swamp Rat
  • Posts: 827
Re: Polyline and Circle to one polyline
« Reply #2 on: February 19, 2017, 09:26:29 AM »
Thank you David for your inputs.

I am happy that it is doable and the direction of circle is not that important.
Can you please give any example ?

Thanks.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Polyline and Circle to one polyline
« Reply #3 on: February 19, 2017, 10:36:58 AM »
Not exactly what you're looking for, but it's close to it... And I am not sure if your example is actually possible to make with LWPOLYLINE...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:lwcitanli ( / p1 p2 li ci gr p pp r c cix )
  2.  
  3.  
  4.   (setq p1 (getpoint "\nPick or specify first point : "))
  5.   (setq p2 (getpoint p1 "\nPick or specify second point : "))
  6.   (setq li (entmakex (list '(0 . "LINE") (cons 10 (trans p1 1 0)) (cons 11 (trans p2 1 0)) '(62 . 1))))
  7.   (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") '(10 0.0 0.0 0.0) '(40 . 0.0) '(62 . 1))))
  8.   (while (/= 3 (car (setq gr (grread t))))
  9.     (setq p (trans (cadr gr) 1 0))
  10.       (progn
  11.         (setq r (/ (distance p pp) 2.0))
  12.         (setq c (mapcar '/ (mapcar '+ p pp) (list 2.0 2.0 2.0)))
  13.         (setq cix (list (cons -1 ci) (cons 10 c) (cons 40 r)))
  14.         (entupd (cdr (assoc -1 (entmod cix))))
  15.       )
  16.     )
  17.   )
  18.   (entdel li)
  19.   (entdel ci)
  20.     (list
  21.       '(0 . "LWPOLYLINE")
  22.       '(100 . "AcDbEntity")
  23.       '(100 . "AcDbPolyline")
  24.       '(90 . 5)
  25.       (cons 70 (* (getvar 'plinegen) 128))
  26.       '(38 . 0.0)
  27.       (cons 10 (trans p1 1 0))
  28.       (cons 10 pp)
  29.       (cons 42 1.0)
  30.       (cons 10 p)
  31.       (cons 42 1.0)
  32.       (cons 10 pp)
  33.       (cons 10 (trans p2 1 0))
  34.       (list 210 0.0 0.0 1.0)
  35.       '(62 . 3)
  36.     )
  37.   )
  38.   (princ)
  39. )
  40.  
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Polyline and Circle to one polyline
« Reply #4 on: February 19, 2017, 12:26:16 PM »
I still stay with my statement that that's quite impossible... Try this code and when LWPOLYLINE is created, try to zoom to touching point - you'll see 2 close points, then make line between those points and finally stretch them with grips so that they are coincident with mid point of just created small line... Now when you zoom out, you'll see that circle disappeared leaving just line - so conclusion is that with the code you can make just as close as this one, but touching is not possible...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:lwcitanli ( / p1 p2 li ci osm p d gr pp r c1 c2 c cix li1 li2 par s pea lw lwx )
  2.   (setq p1 (getpoint "\nPick or specify first point : "))
  3.   (setq p2 (getpoint p1 "\nPick or specify second point : "))
  4.   (setq li (entmakex (list '(0 . "LINE") (cons 10 (trans p1 1 0)) (cons 11 (trans p2 1 0)) '(62 . 1))))
  5.   (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") '(10 0.0 0.0 0.0) '(40 . 0.0) '(62 . 1))))
  6.   (setq osm (getvar 'osmode))
  7.   (setvar 'osmode 512)
  8.   (setq p (getpoint "\nPick or specify point on drawn red LINE : "))
  9.   (setvar 'osmode osm)
  10.   (initget 7)
  11.   (setq d (getdist "\nPick or specify diameter of CIRCLE : "))
  12.   (while (/= 3 (car (setq gr (grread t))))
  13.     (setq pp (cadr gr))
  14.     (setq r (/ d 2.0))
  15.     (setq c1 (polar p (+ (angle p1 p2) (* 0.5 pi)) r))
  16.     (setq c2 (polar p (- (angle p1 p2) (* 0.5 pi)) r))
  17.     (if (< (distance pp c1) (distance pp c2))
  18.       (setq cix (list (cons -1 ci) (cons 10 (setq c c1)) (cons 40 r)))
  19.       (setq cix (list (cons -1 ci) (cons 10 (setq c c2)) (cons 40 r)))
  20.     )
  21.     (entupd (cdr (assoc -1 (entmod cix))))
  22.   )
  23.   (command "_.BREAK" li "_non" p "_non" p)
  24.   (setq li1 li)
  25.   (setq li2 (entlast))
  26.   (setq p1 (vlax-curve-getpointatparam ci (- par (cvunit 0.01 "degree" "radian"))))
  27.   (setq p2 (vlax-curve-getpointatparam ci (+ par (cvunit 0.01 "degree" "radian"))))
  28.   (command "_.BREAK" ci "_non" (trans p1 0 1) "_non" (trans p2 0 1))
  29.   (entupd (cdr (assoc -1
  30.     (entmod
  31.       (cond
  32.         ( (equal (assoc 10 (entget li1)) (cons 10 p) 1e-6)
  33.           (subst (cons 10 (if (< (distance p1 (cdr (assoc 11 (entget li1)))) (distance p2 (cdr (assoc 11 (entget li1))))) p1 p2)) (assoc 10 (entget li1)) (entget li1))
  34.         )
  35.         ( (equal (assoc 11 (entget li1)) (cons 11 p) 1e-6)
  36.           (subst (cons 11 (if (< (distance p1 (cdr (assoc 10 (entget li1)))) (distance p2 (cdr (assoc 10 (entget li1))))) p1 p2)) (assoc 11 (entget li1)) (entget li1))
  37.         )
  38.       )
  39.     )
  40.   )))
  41.   (entupd (cdr (assoc -1
  42.     (entmod
  43.       (cond
  44.         ( (equal (assoc 10 (entget li2)) (cons 10 p) 1e-6)
  45.           (subst (cons 10 (if (< (distance p1 (cdr (assoc 11 (entget li2)))) (distance p2 (cdr (assoc 11 (entget li2))))) p1 p2)) (assoc 10 (entget li2)) (entget li2))
  46.         )
  47.         ( (equal (assoc 11 (entget li2)) (cons 11 p) 1e-6)
  48.           (subst (cons 11 (if (< (distance p1 (cdr (assoc 10 (entget li2)))) (distance p2 (cdr (assoc 10 (entget li2))))) p1 p2)) (assoc 11 (entget li2)) (entget li2))
  49.         )
  50.       )
  51.     )
  52.   )))
  53.   (setq s (ssadd))
  54.   (ssadd li1 s)
  55.   (ssadd li2 s)
  56.   (ssadd ci s)
  57.   (setq pea (getvar 'peditaccept))
  58.   (setvar 'peditaccept 1)
  59.   (command "_.PEDIT" "_M" s "" "_J" "_J" "_E" 0.0 "")
  60.   (setvar 'peditaccept pea)
  61.   (setq lw (entlast))
  62.   (setq lwx (entget lw))
  63.   ;|
  64.   (entupd (cdr (assoc -1 (entmod (setq lwx (subst (cons 10 p) (cons 10 p1) lwx))))))
  65.   (entupd (cdr (assoc -1 (entmod (setq lwx (subst (cons 10 p) (cons 10 p2) lwx))))))
  66.   |;
  67.   (entupd (cdr (assoc -1 (entmod (subst '(62 . 3) '(62 . 1) lwx)))))
  68.   (princ)
  69. )
  70.  

BTW. If you remove comment to 2 lines that were commented at the end of code, CAD won't (entmod) LWPOLYLINE like it's expected... So even CAD knows when it's much, it's too much...
« Last Edit: February 20, 2017, 12:38:28 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

Coder

  • Swamp Rat
  • Posts: 827
Re: Polyline and Circle to one polyline
« Reply #5 on: February 19, 2017, 12:46:55 PM »
Thank you Marko for your beautiful codes, I like that.

You assumed that the polyline is with two end points although its not in my drawing and that just an example in my above images. sorry for that confusion.

Some polylines might have arcs or more than ten segments of each polyline. !

Any other way just to modify the recent polyline with two bulges that represents a circle shape?

Many thanks

Stefan

  • Bull Frog
  • Posts: 319
  • The most I miss IRL is the Undo button
Re: Polyline and Circle to one polyline
« Reply #6 on: February 19, 2017, 04:52:51 PM »
Hi Coder,
Try this lisp. The circles are positioned to the "right" of the polyline. For a clockwise closed polyline, that would be inside...
Code - Auto/Visual Lisp: [Select]
  1. (defun c:test ( / e p d q a b f b1 b2)
  2.   (or *diam* (setq *diam* 100.0))
  3.   (if
  4.     (and
  5.       (setq e (car (entsel)))
  6.       (setq *diam* (cond ((getdist (strcat "\nSpecify circle diameter<" (rtos *diam*) ">: "))) (*diam*)))
  7.       (setq e (vlax-ename->vla-object e)
  8.             d *diam*
  9.       )
  10.     )
  11.     (while (setq p (getpoint "\nSpecify insertion point: "))
  12.             q (vlax-curve-getparamatpoint e p)
  13.             a (fix q)
  14.             b (vla-getbulge e a)
  15.             f (- (angle '(0 0) (vlax-curve-getfirstderiv e q)) (/ pi 2.0)))
  16.       (if
  17.         (equal b 0.0 1e-8)
  18.         (setq b1 nil b2 nil)
  19.         (setq b1 (get_partial_bulge e b a q)
  20.               b2 (get_partial_bulge e b q (+ 1 a))
  21.         )
  22.       )
  23.       (add_vertex e (+ 1 a) p)
  24.       (add_vertex e (+ 2 a) (polar p f d))
  25.       (add_vertex e (+ 3 a) p)
  26.       (vla-setbulge e (+ 1 a) 1.0)
  27.       (vla-setbulge e (+ 2 a) 1.0)
  28.       (if b1 (vla-setbulge e (+ 0 a) b1))
  29.       (if b2 (vla-setbulge e (+ 3 a) b2))
  30.     )
  31.   )
  32.   (princ)
  33. )
  34.  
  35. (defun m2p (a b)
  36.   (if
  37.     (numberp a)
  38.     (/ (+ a b) 2.0)
  39.     (mapcar '(lambda (a b) (/ (+ a b) 2.0)) a b)
  40.   )
  41. )
  42.  
  43. (defun add_vertex (e a p)
  44.       (vlax-make-safearray vlax-vbDouble '(0 . 1))
  45.       (list (car p) (cadr p))
  46.     )
  47.   )
  48. )
  49.  
  50. (defun get_partial_bulge (e b a1 a2 / p1 p2 p3 p4 b1)
  51.   (if
  52.     (equal a1 a2 1e-8)
  53.     b
  54.           p2 (vlax-curve-getpointatparam e a2)
  55.           p3 (vlax-curve-getpointatparam e (m2p a1 a2))
  56.           p4 (m2p p1 p2)
  57.           b1 (/
  58.                (distance p3 p4)
  59.                (distance p1 p4)
  60.                (/ b (abs b))
  61.              )
  62.     )
  63.   )
  64. )

« Last Edit: February 19, 2017, 07:29:48 PM by Stefan »

Lee Mac

  • Seagull
  • Posts: 12906
  • London, England
Re: Polyline and Circle to one polyline
« Reply #7 on: February 19, 2017, 06:33:35 PM »
Superb coding Stefan! - I particularly like the simplicity of your get_partial_bulge to 'scale' the bulge in proportion to the length of the sagitta.

I have a minor suggestion for your m2p function  :-)
Code - Auto/Visual Lisp: [Select]
  1. (defun m2p ( a b )
  2.     (if (numberp a) (/ (+ a b) 2.0) (mapcar 'm2p a b))
  3. )

Stefan

  • Bull Frog
  • Posts: 319
  • The most I miss IRL is the Undo button
Re: Polyline and Circle to one polyline
« Reply #8 on: February 19, 2017, 10:30:00 PM »
Thanks Lee

Funny thing, I always believed that the bulge is defined like in my lisp. Recently I read (in the Help file) that is 1/4 of the included angle, but I never used it like this.

You're right about m2p, thanks for the tip.

Coder

  • Swamp Rat
  • Posts: 827
Re: Polyline and Circle to one polyline
« Reply #9 on: February 20, 2017, 01:07:08 AM »
Hi Coder,
Try this lisp. The circles are positioned to the "right" of the polyline. For a clockwise closed polyline, that would be inside...

This is great Stefan.
The direction of circles is not important recently but the circle itself is the most needed at the mean time.

Thank you so much for your time and great efforts.

David Bethel

  • Swamp Rat
  • Posts: 656
Re: Polyline and Circle to one polyline
« Reply #10 on: February 20, 2017, 08:18:11 AM »
Nice indeed Stefan

I had the add vertex worked out in plain autolisp in my mind.  But for straight segments only.  This is 1 of the times that vla and vlax would be almost mandatory.  -David
R12 Dos - A2K

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Polyline and Circle to one polyline
« Reply #11 on: February 20, 2017, 10:41:08 AM »
Elegant Stefan.  8)
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

Coder

  • Swamp Rat
  • Posts: 827
Re: Polyline and Circle to one polyline
« Reply #12 on: February 23, 2017, 06:06:23 AM »
Hi Stefan.

Is it possible please to have a space between the two end points of the Circle?

Coder

  • Swamp Rat
  • Posts: 827
Re: Polyline and Circle to one polyline
« Reply #13 on: February 23, 2017, 11:46:07 AM »
Can anyone else help me please ?

I need to do this task on many polylines?

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
Re: Polyline and Circle to one polyline
« Reply #14 on: February 23, 2017, 12:24:39 PM »
Can anyone else help me please ?

I need to do this task on many polylines?

I don't know why you need this, but here is one way to do it...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:lwinsciwithgap ( / *error* process adoc osm d r g p k )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if osm
  6.       (setvar 'osmode osm)
  7.     )
  8.     (if ol
  9.       (setvar 'clayer ol)
  10.     )
  11.     (if pea
  12.       (setvar 'peditaccept pea)
  13.     )
  14.     (vla-endundomark adoc)
  15.     (if m
  16.       (prompt m)
  17.     )
  18.     (princ)
  19.   )
  20.  
  21.   (defun process ( r g p k / acos lw ang a b par ca s c p1 p2 sa dr ra cc o ss ol ci cii pea sel )
  22.  
  23.     (vl-load-com)
  24.  
  25.     (defun acos ( x )
  26.       (if (<= -1.0 x 1.0)
  27.         (atan (sqrt (- 1.0 (* x x))) x)
  28.       )
  29.     )
  30.  
  31.     (setq lw (car (nentselp p)))
  32.     (setq ang (angle '(0 0) (vlax-curve-getfirstderiv lw (vlax-curve-getparamatpoint lw (trans p 1 0)))))
  33.     (if (= k "Right")
  34.       (setq a (- ang (* 0.5 pi)))
  35.       (setq a (+ ang (* 0.5 pi)))
  36.     )
  37.     (setq b (vla-getbulge (vlax-ename->vla-object lw) (float (fix (setq par (vlax-curve-getparamatpoint lw (trans p 1 0)))))))
  38.     (if (zerop b)
  39.       (progn
  40.         (setq ca (acos (- 1.0 (/ (expt g 2) (* 2 (expt r 2))))))
  41.         (setq s (* (abs (/ (sin (/ ca 4)) (cos (/ ca 4)))) (/ g 2)))
  42.         (setq c (polar p a (- r s)))
  43.         (setq p1 (polar p ang (- (/ g 2))))
  44.         (setq p2 (polar p ang (/ g 2)))
  45.       )
  46.       (progn
  47.         (setq ca (acos (- 1.0 (/ (expt g 2) (* 2 (expt r 2))))))
  48.         (setq s (* (abs (/ (sin (/ ca 4)) (cos (/ ca 4)))) (/ g 2)))
  49.         (setq sa (* (abs b) (/ (distance (vlax-curve-getpointatparam lw (float (fix par))) (vlax-curve-getpointatparam lw (float (1+ (fix par))))) 2)))
  50.         (setq dr (/ (/ (distance (vlax-curve-getpointatparam lw (float (fix par))) (vlax-curve-getpointatparam lw (float (1+ (fix par))))) 2) (/ (sin (* 2 (atan (abs b)))) (cos (* 2 (atan (abs b)))))))
  51.         (setq ra (+ sa dr))
  52.         (setq cc (inters (vlax-curve-getpointatparam lw (float (+ (fix par) 0.25))) (polar (vlax-curve-getpointatparam lw (float (+ (fix par) 0.25))) (+ (angle '(0 0) (vlax-curve-getfirstderiv lw (float (+ (fix par) 0.25)))) (* 0.5 pi)) 1.0) (vlax-curve-getpointatparam lw (float (- (1+ (fix par)) 0.25))) (polar (vlax-curve-getpointatparam lw (float (- (1+ (fix par)) 0.25))) (+ (angle '(0 0) (vlax-curve-getfirstderiv lw (float (- (1+ (fix par)) 0.25)))) (* 0.5 pi)) 1.0) nil))
  53.         (setq o (acos (- 1.0 (/ (expt g 2) (* 2 (expt ra 2))))))
  54.         (setq ss (* (abs (/ (sin (/ o 4)) (cos (/ o 4)))) (/ g 2)))
  55.         (setq p1 (polar cc (- (angle cc p) (/ o 2)) ra))
  56.         (setq p2 (polar cc (+ (angle cc p) (/ o 2)) ra))
  57.           (mapcar 'set '(p1 p2) (list p2 p1))
  58.         )
  59.         (setq c (polar (mapcar '/ (mapcar '+ p1 p2) (list 2.0 2.0 2.0)) a (- r s)))
  60.       )
  61.     )
  62.     (setq ol (getvar 'clayer))
  63.     (setvar 'clayer (cdr (assoc 8 (entget lw))))
  64.     (setq ci (entmakex (list '(0 . "CIRCLE") '(100 . "AcDbEntity") '(100 . "AcDbCircle") (cons 10 c) (cons 40 r))))
  65.     (setq cii (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object ci))))
  66.       (entdel cii)
  67.       (progn
  68.         (entdel ci)
  69.         (setq ci cii)
  70.       )
  71.     )
  72.     (command "_.BREAK" lw "_non" p1 "_non" p2)
  73.     (setq sel (ssadd))
  74.     (ssadd (entlast) sel)
  75.     (ssadd lw sel)
  76.     (ssadd ci sel)
  77.     (setq pea (getvar 'peditaccept))
  78.     (setvar 'peditaccept 1)
  79.     (command "_.PEDIT" "_M" sel "" "_J" "_J" "_E" 0.05 "")
  80.     (setvar 'peditaccept pea)
  81.     (setvar 'clayer ol)
  82.   )
  83.  
  84.   (setq osm (getvar 'osmode))
  85.   (setvar 'osmode 512)
  86.   (initget 7)
  87.   (setq d (getdist "\nPick or specify diameter : "))
  88.   (setq r (/ d 2))
  89.   (initget 7)
  90.   (setq g (getdist (strcat "\nPick or specify gap <must be smaller than : " (rtos d 2 20) "> : ")))
  91.   (while (setq p (getpoint "\nPick or specify insertion point on LWPOLYLINE <ENTER-FINISH> : "))
  92.     (initget "Right Left")
  93.     (setq k (cond ( (getkword "\nSpecify side [Right/Left] <Right> : ") ) ( t "Right" )))
  94.     (process r g p k)
  95.   )
  96.   (*error* nil)
  97. )
  98.  

HTH., M.R.
« Last Edit: February 24, 2017, 07:48:01 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube