marko_ribar Posted April 16, 2016 Share Posted April 16, 2016 New "plintav-opt.lsp" can be found here posted in code tags : http://www.cadtutor.net/forum/showthread.php?96478-How-to-delete-one-line-from-each-joint&p=659455#post659455 Regards, M.R. Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted April 20, 2016 Share Posted April 20, 2016 (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 May 2, 2016 by marko_ribar code changed... Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted April 21, 2016 Share Posted April 21, 2016 Updated last posted code... M.R. Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted April 22, 2016 Share Posted April 22, 2016 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... Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted April 24, 2016 Share Posted April 24, 2016 This could also be part of PLINETOOLS package... http://www.cadtutor.net/forum/showthread.php?96590-Join-multiple-collinear-polylines&p=#7 M.R. Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted May 1, 2016 Share Posted May 1, 2016 (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 May 2, 2016 by marko_ribar Quote Link to comment Share on other sites More sharing options...
marko_ribar Posted May 2, 2016 Share Posted May 2, 2016 (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 March 29, 2023 by marko_ribar 1 Quote Link to comment Share on other sites More sharing options...
ajc Posted April 22, 2018 Share Posted April 22, 2018 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, Quote Link to comment Share on other sites More sharing options...
aloy Posted April 25, 2018 Share Posted April 25, 2018 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. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.