TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Topic started by: xiaxiang on March 10, 2011, 08:57:04 PM

Title: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 10, 2011, 08:57:04 PM
Hi,All
I need to connect some LWPOLYLINES just like my animation.Maybe It's mentioned as the Alan's topic about grread :
http://www.theswamp.org/index.php?topic=33469.0 (http://www.theswamp.org/index.php?topic=33469.0)
I just want some code to help me drawing such a closed pline.I've try it by myself several days,but I found that I can do nothing.
Is there some useful code or idea?
Need your help!Thanks to all!
And I will stay online and keep Refreshing the  Screen and waiting for your suggestion (code) .

Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 10, 2011, 09:10:45 PM
And ,It's my code to draw pline.It's not what I want! Because I must to do that for several steps as my animation.
The code is used from QJCHENhttp://www.xdcad.net/forum/showthread.php?postid=2278579#post2278579 (http://www.xdcad.net/forum/showthread.php?postid=2278579#post2278579)
AND VVA http://www.theswamp.org/index.php?topic=26664.0 (http://www.theswamp.org/index.php?topic=26664.0).
Title: Re: Need your help,Object Connect&Draw pline
Post by: LE3 on March 10, 2011, 09:18:26 PM
1. Make a selection of the polylines, that form the letter shape.
2. Explode them and make a selection of those lines.
3. Loop into all those lines, and find the ones that are collinear and make a set of lists of those groups.
4. Loop into the sets of collinear groups and find the extreme points and make a pair of points lists.
5. Then just draw lines from each pair of points.

HTH.
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 10, 2011, 09:45:14 PM
1. Make a selection of the polylines, that form the letter shape.
2. Explode them and make a selection of those lines.
3. Loop into all those lines, and find the ones that are collinear and make a set of lists of those groups.
4. Loop into the sets of collinear groups and find the extreme points and make a pair of points lists.
5. Then just draw lines from each pair of points.

HTH.
Thanks Luis
Can you make this routine for me?
 :roll: :wink: I'm shy to say that...
Title: Re: Need your help,Object Connect&Draw pline
Post by: pkohut on March 10, 2011, 10:10:03 PM
1. Make a selection of the polylines, that form the letter shape.
2. Explode them and make a selection of those lines.
3. Loop into all those lines, and find the ones that are collinear and make a set of lists of those groups.
4. Loop into the sets of collinear groups and find the extreme points and make a pair of points lists.
5. Then just draw lines from each pair of points.

HTH.

alternative
2a. remove duplicates, ie. if line 1 is a duplicate of line 2 remove both lines. This will get rid of the interior lines. There could be more than 1 duplicate of a line, get rid of those too.
3a. pedit join the selection, shape outline is a polyline.
     3b. iterate new pline, checking segment angle, remove segment runs that have the same angle. Repeat for rest of pline segments.
Title: Re: Need your help,Object Connect&Draw pline
Post by: LE3 on March 10, 2011, 10:15:26 PM
1. Make a selection of the polylines, that form the letter shape.
2. Explode them and make a selection of those lines.
3. Loop into all those lines, and find the ones that are collinear and make a set of lists of those groups.
4. Loop into the sets of collinear groups and find the extreme points and make a pair of points lists.
5. Then just draw lines from each pair of points.

HTH.
Thanks Luis
Can you make this routine for me?
 :roll: :wink: I'm shy to say that...

Nope, sorry I can't.
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on March 11, 2011, 12:09:03 PM
hi you can use the TSP way to get it . if you just to get a bold text frame , you can use wmfout&in then tanslate into regions , union , andthen trans... into PLine .
Code: [Select]
;;;by ElpanovEvgeniy
;;;From  http://www.theswamp.org/index.php?topic=30434.75
;;;edit by GSLS(SS) 2010.2
(defun c:TSP (/  D D0 D1 E ENT EP LL LS P m pt) ;_(setq l ptlst)
  (setq  
    l (my-getpt)  
    m (vlex-extents l)
    pt (list (+ (caadr m) 100.0) (- (cadar m) 100.0))
    l (cons pt l)
    ll (Graham-scan l)  
    ent (entmakex
 (append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(8 . "temp")
'(62 . 1)
'(100 . "AcDbPolyline")
(cons 90 (length l))
'(70 . 1)
 ) ;_  list
 (mapcar (function (lambda (a) (cons 10 a))) ll)
 ) ;_  append
) ;_  entmakex  
    l (mapcar
 (function cddr)
 (vl-sort
   (mapcar
     (Function
(lambda (a / b)
 (cons
   (distance a
     (setq b (vlax-curve-getClosestPointTo ent a))
   )
   (cons (vlax-curve-getParamAtPoint ent b) a)
 ) ;_  cons
) ;_  lambda
     ) ;_  Function
     l
   ) ;_  mapcar
   (function (lambda (a b)
(if (equal (car a) (car b) 1)
 (<= (cadr a) (cadr b))
 (< (car a) (car b))
) ;_  if
     ) ;_  lambda
   ) ;_  function
 ) ;_  vl-sort
) ;_  mapcar
    ls l
  ) ;_  setq
  (foreach a ll (setq ls (vl-remove a ls)))
  (foreach a ls
    (setq p (vlax-curve-getParamAtPoint
     ent
     (vlax-curve-getClosestPointTo ent a)
   )
 p (if (zerop (rem p 1.))
     (if (zerop p)
(vlax-curve-getEndParam ent)
(1- p)
     ) ;_  if
     (fix p)
   ) ;_  if
 p (vlax-curve-getPointAtParam ent p)
 p (list 10 (car p) (cadr p))
    ) ;_  setq
    (entmod (append (reverse (member p (reverse (entget ent))))
   (list (cons 10 a))
   (cdr (member p (entget ent)))
   ) ;_  append
    ) ;_  entmod
  ) ;_  foreach
  (foreach a l (setq ll (vl-remove a ll)))
  (entmod (vl-remove-if
   (function (lambda (a) (member (cdr a) ll)))
   (entget ent)
 )
  )
  (setq l  (mapcar (function cdr)
  (vl-remove-if-not
    (function (lambda (a) (= (car a) 10)))
    (entget ent)
  )
  ) ;_  mapcar
l  (mapcar (function list) (cons (last l) l) l)
ep (length l)
  ) ;_  setq
  (defun f1 (a ent / p)
    (setq p (vlax-curve-getPointAtParam
     ent
     (fix (vlax-curve-getParamAtPoint
    ent
    (vlax-curve-getClosestPointTo ent a)
  )
     )
   ) ;_  vlax-curve-getPointAtParam
 p (list 10 (car p) (cadr p))
    ) ;_  setq ;_  setq
    (entmod (append (reverse (member p (reverse (entget ent))))
   (list (cons 10 a))
   (cdr (member p (entget ent)))
   ) ;_  append
    ) ;_  entmod
  ) ;_  defun
  (setq d0 (vlax-curve-getDistAtParam ent ep))
  (while
    (> d0
       (progn
(foreach a l
  (setq e (entget ent)
d (vlax-curve-getDistAtParam ent ep)
  ) ;_  setq
  (entmod (vl-remove (cons 10 (car a))
     (vl-remove (cons 10 (cadr a)) e)
  )
  )
  (f1 (car a) ent)
  (f1 (cadr a) ent)
  (if (<= d
  (setq d1 (vlax-curve-getDistAtParam
     ent
     (vlax-curve-getEndParam ent)
   )
  )
      )
    (entmod e)
    (setq d d1
  e (entget ent)
    ) ;_  setq
  ) ;_  if
  (entmod (vl-remove (cons 10 (car a))
     (vl-remove (cons 10 (cadr a)) e)
  )
  )
  (f1 (cadr a) ent)
  (f1 (car a) ent)
  (if (<= d
  (setq d1 (vlax-curve-getDistAtParam
     ent
     (vlax-curve-getEndParam ent)
   )
  )
      )
    (entmod e)
    (setq d d1
  e (entget ent)
    ) ;_  setq
  ) ;_  if
) ;_  foreach
d
       ) ;_  progn
    ) ;_  <
     (setq d0 d)
  ) ;_  while
  (entmod (vl-remove (cons 10 pt)
     (entget ent)
  )
  )
  (setq d (vlax-curve-getDistAtParam
     ent
     (vlax-curve-getEndParam ent)
   )
  )
  (princ (strcat "\nPolyline Length: " (rtos d 2 4) " mm."))
  (princ)
)
;;; get BL UR points
(defun vlex-extents (plist)
  (list (apply
 'mapcar
 (cons 'min plist)
)
(apply
 'mapcar
 (cons 'max plist)
)
  )
)
;;;
(defun my-getpt (/ ss i s1 ptlst)
  (setq ss (ssget '((0 . "CIRCLE,*LINE*,POINT,ARC,ELLIPSE,TEXT"))))
  (setq ptlst nil
i -1
  )
  (while (setq s1 (ssname ss (setq i (1+ i))))
    (setq ptlst (append ptlst (ss-assoc 10 (entget s1))))        
  )
  ptlst
)
;;;Use Scanning Method convex hull points
;;;by highflybird
(defun Graham-scan (ptl / hPs rPs PsY Pt0 sPs P Q)
  (if (< (length ptl) 4) ;3点以下
    ptl ;是本集合
    (progn
      (setq rPs (mapcar (function (lambda (x)
      (if (= (length x) 3)
(cdr x)
x
      )
    )
  )
  (mapcar 'reverse ptl)
  ) ;点_表的X和Y交换
   PsY (mapcar 'cadr ptl) ;_点表的Y值的表
   Pt0 (reverse (assoc (apply 'min PsY) rPs)) ;_最下面的点      
   sPs (sort-ad ptl Pt0) ;_按角度距离排序点集
   hPs (list (caddr sPs) (cadr sPs) Pt0) ;_开始的三点
      )
      (foreach n (cdddr sPs) ;从第4点开始
(setq hPs (cons n hPs) ;把Pi加入到凸集
     P     (cadr hPs) ;Pi-1
     Q     (caddr hPs) ;Pi-2
)
(while (and q (> (det n P Q) -1e-6)) ;如果左转
 (setq hPs (cons n (cddr hPs)) ;删除Pi-1点
P      (cadr hPs) ;得到新的Pi-1点
Q      (caddr hPs) ;得到新的Pi-2点
 )
)
      )
      hPs ;返回凸集
    )
  )
)
;;;Anchored to the bottom point, angle and distance classification in accordance with point set
(defun sort-ad (ptlist pt / Ang1 Ang2)
  (vl-sort ptlist
  (function
    (lambda (e1 e2)
      (setq ang1 (angle pt e1)
    ang2 (angle pt e2))
      (if (equal ang1 ang2 1e-6)
(< (distance pt e1) (distance pt e2))
(< ang1 ang2)
      )
    )
  )
  )
)

Title: Re: Need your help,Object Connect&Draw pline
Post by: LE3 on March 11, 2011, 12:17:57 PM
That's nice, but guess it is better to allow the OP to try it first, post his/her code/efforts, then show or provide hints, pseudo code, semi solutions, that way he/she/all can learn, not just to simply providing an out of box solution and do his/her homework, have seen these type of posting lately here, instead why not post those on the 'show your stuff', that way at least they can look good.

Maybe it is me, but take it as there it is just two cents.
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on March 11, 2011, 12:26:37 PM
I just think people can not do too much duplication of effort, the Giants always stand on the shoulders of great men, I hope we are all giants.
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 12, 2011, 04:56:14 AM
I just think people can not do too much duplication of effort, the Giants always stand on the shoulders of great men, I hope we are all giants.


Thanks chlh_jd !
I will try that .The idea your posted is good for me. I couldn't find this way before.
非常感谢!
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 12, 2011, 05:09:26 AM
That's nice, but guess it is better to allow the OP to try it first, post his/her code/, then show or provide hints, pseudo code, semi solutions, that way he/she/all can learn, not just to simply providing an out of box solution and do his/her homework, have seen these type of posting lately here, instead why not post those on the 'show your stuff', that way at least they can look good.

Maybe it is me, but take it as there it is just two cents.
Hi Luis
The idea that you bring to me is good .I just think that I couldn't do this work with one step.The efforts is just like my second post in this topic.I'm not satisfied with it.
As the fact ,I really try all by myself.
Thanks.
xiax
Title: Re: Need your help,Object Connect&Draw pline
Post by: Kerry on March 12, 2011, 05:33:44 AM
hi you can use the TSP way to get it . if you just to get a bold text frame , you can use wmfout&in then tanslate into regions , union , andthen trans... into PLine .
< ... >

Good solution !!
Would be nice if you could credit the original author :)

You are correct ; we all stand on the shoulders of giants to some degree.

Regards
 
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on March 12, 2011, 07:10:58 AM
Thanks Kerry !
I'll find the 'TSP' code author , and modify the reply .
Title: Re: Need your help,Object Connect&Draw pline
Post by: Lee Mac on March 12, 2011, 07:16:43 AM
Thanks Kerry !
I'll find the 'TSP' code author , and modify the reply .

From the coding style it looks like Evgeniy, but I could be way off  ;-)
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on March 12, 2011, 07:28:19 AM
You are right , Lee .
The 'TSP' code I got it before I came in TheSwamp , So I'm sorry to forget the author .
by the way , I test the code again and again , it take wrong result , when the points is much .
I try to use the General genetic algorithm , but up to now, I have not done it .

Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 28, 2011, 04:59:56 AM
hi you can use the TSP way to get it . if you just to get a bold text frame , you can use wmfout&in then tanslate into regions , union , andthen trans... into PLine .

Hi,chlh_jd

I failed when using your code.Please check my lsp file that have been uploaded.
It's my function that added in your code. Is it right?
Code: [Select]
(defun ss-assoc (a lst / b lst2)
  (while (setq b (assoc a lst))
    (setq lst  (cdr (member b lst))
   lst2 (cons (cdr b) lst2)
    )
  )
  (reverse lst2)
)
Code: [Select]
(defun det (p1 p2 p3 / dx1 dy1 dx2 dy2)   
(setq dx1 (- (car  p2) (car  p1))
            dy1 (- (cadr p2) (cadr p1))
dx2 (- (car  p3) (car  p1))
dy2 (- (cadr p3) (cadr p1))   )   
(- (* dx1 dy2) (* dx2 dy1))
)
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on March 28, 2011, 09:52:19 AM
Hi , Xiaxiang . I'm sorry to forget the functions 'ss-assoc' & 'det'
Code: [Select]
(defun ss-assoc (a lst / b lst2)
  (while (setq b (assoc a lst))
    (setq lst  (cdr (member b lst))
  lst2 (cons (cdr b) lst2)
    )
  )
  (reverse lst2)
)
(defun det (p1 p2 p3)
  (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
     (* (- (car p3) (car p1)) (- (cadr p2) (cadr p1)))
  )
)
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on March 28, 2011, 10:10:36 AM
hi Xiaxiang .
TSP fun given before , is cond the GA method , so it's possible to get wrong result .
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on March 28, 2011, 11:58:20 AM
hi Xiaxiang , here is new version .
Code: [Select]
;;;by ElpanovEvgeniy
;;;From  http://www.theswamp.org/index.php?topic=30434.75
;;;edit by GSLS(SS) 2010.3
(defun c:TSP (/ l foo rs1 rs2 obj) ;_(setq l ptlst)
  (defun gsls-XY->R (pt ang / an1 dis an2)
    (setq an1 (angle '(0.0 0.0 0.0) pt)
  dis (distance '(0.0 0.0 0.0) pt)
  an2 (- an1 ang))
    (list (* dis (cos an2)) (* dis (sin an2)))
  )
  (defun vlex-extents (pts)
    (list (apply'mapcar(cons 'min pts))
  (apply'mapcar(cons 'max pts)))
  )
  ;; Convex hull of pts , Graham scan method
  ;; by Highflybird
  (defun Graham-scan (ptl / hPs rPs PsY Pt0 sPs P Q)
    (if (< (length ptl) 4) ;3点以下
      ptl ;是本集合
      (progn
(setq rPs (mapcar (function (lambda (x)
      (if (= (length x) 3)
(cdr x) x)))
  (mapcar 'reverse ptl));_点表的X和Y交换
      PsY (mapcar 'cadr ptl) ;_点表的Y值的表
      Pt0 (reverse (assoc (apply 'min PsY) rPs)) ;_最下面的点       
      sPs (sort-ad ptl Pt0) ;_按角度距离排序点集
      hPs (list (caddr sPs) (cadr sPs) Pt0) ;_开始的三点
)
(foreach n (cdddr sPs) ;从第4点开始
  (setq hPs (cons n hPs) ;把Pi加入到凸集
P   (cadr hPs) ;Pi-1
Q   (caddr hPs) ;Pi-2
  )
  (while (and q (> (det n P Q) -1e-6)) ;如果左转
    (setq hPs (cons n (cddr hPs)) ;删除Pi-1点
  P   (cadr hPs) ;得到新的Pi-1点
  Q   (caddr hPs) ;得到新的Pi-2点
    )))
hPs ;返回凸集
      ))
  )
  ;;Sort pts by angle & distance
  (defun sort-ad (ptlist pt / An1 An2)
    (vl-sort ptlist
     (function (lambda (e1 e2)
(setq an1 (angle pt e1)
       an2 (angle pt e2)
)
(if (equal an1 an2 1e-6)
   (< (distance pt e1) (distance pt e2))
   (< an1 an2)
)))))
  ;;det of triangle , eq double area of triangle
  (defun det (p1 p2 p3)
    (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
       (* (- (car p3) (car p1)) (- (cadr p2) (cadr p1)))
    ))
  ;;Here changed into lambda fun , because uses it twice .
  (defun foo (l / f1 D D0 D1 E ENT EP LL LS P m pt)
    (setq m   (vlex-extents l)
  pt  (list (+ (caadr m) 100.0) (- (cadar m) 100.0))
  l   (cons pt l)
  ll  (Graham-scan l)
  ent (entmakex
(append (list '(0 . "LWPOLYLINE")
      '(100 . "AcDbEntity")
      '(8 . "temp")
      '(62 . 1)
      '(100 . "AcDbPolyline")
      (cons 90 (length l))
      '(70 . 1)
) ;_  list
(mapcar (function (lambda (a) (cons 10 a))) ll)
) ;_  append
      ) ;_  entmakex 
  l   (mapcar(function cddr)(vl-sort(mapcar
    (Function(lambda (a / b)(cons
  (distance a(setq b (vlax-curve-getClosestPointTo ent a)))
  (cons (vlax-curve-getParamAtPoint ent b) a)
) ;_  cons
      ) ;_  lambda
    ) ;_  Function
    l
  ) ;_  mapcar
  (function (lambda (a b)
      (if (equal (car a) (car b) 1)
(<= (cadr a) (cadr b))
(< (car a) (car b))
      ) ;_  if
    ) ;_  lambda
  ) ;_  function
) ;_  vl-sort
      ) ;_  mapcar
  ls  l
    ) ;_  setq
    (foreach a ll (setq ls (vl-remove a ls)))
    (foreach a ls
      (setq p (vlax-curve-getParamAtPoint
ent
(vlax-curve-getClosestPointTo ent a)
      )
    p (if (zerop (rem p 1.))
(if (zerop p)
  (vlax-curve-getEndParam ent)
  (1- p)
) ;_  if
(fix p)
      ) ;_  if
    p (vlax-curve-getPointAtParam ent p)
    p (list 10 (car p) (cadr p))
      ) ;_  setq
      (entmod (append (reverse (member p (reverse (entget ent))))
      (list (cons 10 a))
      (cdr (member p (entget ent)))
      ) ;_  append
      ) ;_  entmod
    ) ;_  foreach
    (foreach a l (setq ll (vl-remove a ll)))
    (entmod (vl-remove-if
      (function (lambda (a) (member (cdr a) ll)))
      (entget ent)
    )
    )
    (setq l  (mapcar (function cdr)
     (vl-remove-if-not
       (function (lambda (a) (= (car a) 10)))
       (entget ent)
     )
     ) ;_  mapcar
  l  (mapcar (function list) (cons (last l) l) l)
  ep (length l)
    ) ;_  setq
    (defun f1 (a ent / p)
      (setq p (vlax-curve-getPointAtParam
ent
(fix (vlax-curve-getParamAtPoint
       ent
       (vlax-curve-getClosestPointTo ent a)
     )
)
      ) ;_  vlax-curve-getPointAtParam
    p (list 10 (car p) (cadr p))
      ) ;_  setq ;_  setq
      (entmod (append (reverse (member p (reverse (entget ent))))
      (list (cons 10 a))
      (cdr (member p (entget ent)))
      ) ;_  append
      ) ;_  entmod
    ) ;_  defun
    (setq d0 (vlax-curve-getDistAtParam ent ep))
    (while
      (> d0
(progn
   (foreach a l
     (setq e (entget ent)
   d (vlax-curve-getDistAtParam ent ep)
     ) ;_  setq
     (entmod (vl-remove (cons 10 (car a))
(vl-remove (cons 10 (cadr a)) e)
     ))
     (f1 (car a) ent)
     (f1 (cadr a) ent)
     (if (<= d
     (setq d1 (vlax-curve-getDistAtParam
ent
(vlax-curve-getEndParam ent)
      )))
       (entmod e)
       (setq d d1
     e (entget ent)) ;_  setq
     ) ;_  if
     (entmod (vl-remove (cons 10 (car a))
(vl-remove (cons 10 (cadr a)) e)
     )
     )
     (f1 (cadr a) ent)
     (f1 (car a) ent)
     (if (<= d
     (setq d1 (vlax-curve-getDistAtParam
ent
(vlax-curve-getEndParam ent)
      )))
       (entmod e)
       (setq d d1
     e (entget ent)) ;_  setq
     ) ;_  if
   ) ;_  foreach
   d
) ;_  progn
      ) ;_  <
       (setq d0 d)
    ) ;_  while
    (entmod (vl-remove (cons 10 pt)
       (entget ent)
    )
    )
    (setq d (vlax-curve-getDistAtParam
      ent
      (vlax-curve-getEndParam ent)
    ))
    (list d (entlast))
  )
  ;;;routine ...
  (setq l (my-getpt))
  (setq rs1 (foo l))
  (setq rs2 (foo (mapcar (function (lambda (x)
     (gsls-XY->R x (/ pi -2.))
   ))
l
);_rotate pts by -pi/2 , cal the TSP polyline again .
    ))
  (cond ((<= (car rs1) (car rs2))
(entdel (cadr rs2))
(princ (strcat "\nPolyline Length: " (rtos (car rs1) 2 4) " mm."))
)
(t
(setq obj (vlax-ename->vla-object (cadr rs2)))
(vla-TransformBy  obj
   (vlax-tmatrix
     '((0. 1. 0. 0.)
       (-1. 0. 0. 0.)
       (0. 0. 1.0 0.)
       (0. 0. 0. 1.0)
      )))
(vlax-release-object obj)
(entdel (cadr rs1))
(princ (strcat "\nPolyline Length: " (rtos (car rs2) 2 4) " mm.") )
)
  )
  (princ)
)
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 28, 2011, 09:16:20 PM
hi Xiaxiang , here is new version .
Code: [Select]
(setq l (my-getpt))
Thanks,chlh_jd!
In line 205 ,function (my-getpt).Please ,bring it for me.
 :-) :-) :-)
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on March 29, 2011, 01:23:06 AM
See reply #6&#16, in mine it's a large routine for "CIRCLE,*LINE*,POINT,ARC,ELLIPSE,TEXT" , and I uses it in structure , so it's bypass .
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 29, 2011, 02:27:47 AM
See reply #6&#16, in mine it's a large routine for "CIRCLE,*LINE*,POINT,ARC,ELLIPSE,TEXT" , and I uses it in structure , so it's bypass .
OK,chlh_jd
Nice Work! Many thanks!
I got what I want using your new version code on the sample dwg in reply #15.
And, another matter bothered me.In the new sample dwg that should be posted in this reply, I failed with generating pline.
Please,Try it for me :oops:  :oops:  :oops:
万分感谢!
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 29, 2011, 02:38:52 AM
I don't know the reason .Who can clarify the TSP way for me?
Why did I get wrong result using "tsp" code ? It seemed like I could do it well with every try when I mastered the Methods.
Title: Re: Need your help,Object Connect&Draw pline
Post by: Sam on March 29, 2011, 03:24:40 AM
hi Xiaxiang , here is new version .
Code: [Select]
;;;by ElpanovEvgeniy
;;;From  http://www.theswamp.org/index.php?topic=30434.75
;;;edit by GSLS(SS) 2010.3
(defun c:TSP (/ l foo rs1 rs2 obj) ;_(setq l ptlst)
  (defun gsls-XY->R (pt ang / an1 dis an2)
    (setq an1 (angle '(0.0 0.0 0.0) pt)
  dis (distance '(0.0 0.0 0.0) pt)
  an2 (- an1 ang))
    (list (* dis (cos an2)) (* dis (sin an2)))
  )
  (defun vlex-extents (pts)
    (list (apply'mapcar(cons 'min pts))
  (apply'mapcar(cons 'max pts)))
  )
  ;; Convex hull of pts , Graham scan method
  ;; by Highflybird
  (defun Graham-scan (ptl / hPs rPs PsY Pt0 sPs P Q)
    (if (< (length ptl) 4) ;3点以下
      ptl ;是本集合
      (progn
(setq rPs (mapcar (function (lambda (x)
      (if (= (length x) 3)
(cdr x) x)))
  (mapcar 'reverse ptl));_点表的X和Y交换
      PsY (mapcar 'cadr ptl) ;_点表的Y值的表
      Pt0 (reverse (assoc (apply 'min PsY) rPs)) ;_最下面的点       
      sPs (sort-ad ptl Pt0) ;_按角度距离排序点集
      hPs (list (caddr sPs) (cadr sPs) Pt0) ;_开始的三点
)
(foreach n (cdddr sPs) ;从第4点开始
  (setq hPs (cons n hPs) ;把Pi加入到凸集
P   (cadr hPs) ;Pi-1
Q   (caddr hPs) ;Pi-2
  )
  (while (and q (> (det n P Q) -1e-6)) ;如果左转
    (setq hPs (cons n (cddr hPs)) ;删除Pi-1点
  P   (cadr hPs) ;得到新的Pi-1点
  Q   (caddr hPs) ;得到新的Pi-2点
    )))
hPs ;返回凸集
      ))
  )
  ;;Sort pts by angle & distance
  (defun sort-ad (ptlist pt / An1 An2)
    (vl-sort ptlist
     (function (lambda (e1 e2)
(setq an1 (angle pt e1)
       an2 (angle pt e2)
)
(if (equal an1 an2 1e-6)
   (< (distance pt e1) (distance pt e2))
   (< an1 an2)
)))))
  ;;det of triangle , eq double area of triangle
  (defun det (p1 p2 p3)
    (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
       (* (- (car p3) (car p1)) (- (cadr p2) (cadr p1)))
    ))
  ;;Here changed into lambda fun , because uses it twice .
  (defun foo (l / f1 D D0 D1 E ENT EP LL LS P m pt)
    (setq m   (vlex-extents l)
  pt  (list (+ (caadr m) 100.0) (- (cadar m) 100.0))
  l   (cons pt l)
  ll  (Graham-scan l)
  ent (entmakex
(append (list '(0 . "LWPOLYLINE")
      '(100 . "AcDbEntity")
      '(8 . "temp")
      '(62 . 1)
      '(100 . "AcDbPolyline")
      (cons 90 (length l))
      '(70 . 1)
) ;_  list
(mapcar (function (lambda (a) (cons 10 a))) ll)
) ;_  append
      ) ;_  entmakex 
  l   (mapcar(function cddr)(vl-sort(mapcar
    (Function(lambda (a / b)(cons
  (distance a(setq b (vlax-curve-getClosestPointTo ent a)))
  (cons (vlax-curve-getParamAtPoint ent b) a)
) ;_  cons
      ) ;_  lambda
    ) ;_  Function
    l
  ) ;_  mapcar
  (function (lambda (a b)
      (if (equal (car a) (car b) 1)
(<= (cadr a) (cadr b))
(< (car a) (car b))
      ) ;_  if
    ) ;_  lambda
  ) ;_  function
) ;_  vl-sort
      ) ;_  mapcar
  ls  l
    ) ;_  setq
    (foreach a ll (setq ls (vl-remove a ls)))
    (foreach a ls
      (setq p (vlax-curve-getParamAtPoint
ent
(vlax-curve-getClosestPointTo ent a)
      )
    p (if (zerop (rem p 1.))
(if (zerop p)
  (vlax-curve-getEndParam ent)
  (1- p)
) ;_  if
(fix p)
      ) ;_  if
    p (vlax-curve-getPointAtParam ent p)
    p (list 10 (car p) (cadr p))
      ) ;_  setq
      (entmod (append (reverse (member p (reverse (entget ent))))
      (list (cons 10 a))
      (cdr (member p (entget ent)))
      ) ;_  append
      ) ;_  entmod
    ) ;_  foreach
    (foreach a l (setq ll (vl-remove a ll)))
    (entmod (vl-remove-if
      (function (lambda (a) (member (cdr a) ll)))
      (entget ent)
    )
    )
    (setq l  (mapcar (function cdr)
     (vl-remove-if-not
       (function (lambda (a) (= (car a) 10)))
       (entget ent)
     )
     ) ;_  mapcar
  l  (mapcar (function list) (cons (last l) l) l)
  ep (length l)
    ) ;_  setq
    (defun f1 (a ent / p)
      (setq p (vlax-curve-getPointAtParam
ent
(fix (vlax-curve-getParamAtPoint
       ent
       (vlax-curve-getClosestPointTo ent a)
     )
)
      ) ;_  vlax-curve-getPointAtParam
    p (list 10 (car p) (cadr p))
      ) ;_  setq ;_  setq
      (entmod (append (reverse (member p (reverse (entget ent))))
      (list (cons 10 a))
      (cdr (member p (entget ent)))
      ) ;_  append
      ) ;_  entmod
    ) ;_  defun
    (setq d0 (vlax-curve-getDistAtParam ent ep))
    (while
      (> d0
(progn
   (foreach a l
     (setq e (entget ent)
   d (vlax-curve-getDistAtParam ent ep)
     ) ;_  setq
     (entmod (vl-remove (cons 10 (car a))
(vl-remove (cons 10 (cadr a)) e)
     ))
     (f1 (car a) ent)
     (f1 (cadr a) ent)
     (if (<= d
     (setq d1 (vlax-curve-getDistAtParam
ent
(vlax-curve-getEndParam ent)
      )))
       (entmod e)
       (setq d d1
     e (entget ent)) ;_  setq
     ) ;_  if
     (entmod (vl-remove (cons 10 (car a))
(vl-remove (cons 10 (cadr a)) e)
     )
     )
     (f1 (cadr a) ent)
     (f1 (car a) ent)
     (if (<= d
     (setq d1 (vlax-curve-getDistAtParam
ent
(vlax-curve-getEndParam ent)
      )))
       (entmod e)
       (setq d d1
     e (entget ent)) ;_  setq
     ) ;_  if
   ) ;_  foreach
   d
) ;_  progn
      ) ;_  <
       (setq d0 d)
    ) ;_  while
    (entmod (vl-remove (cons 10 pt)
       (entget ent)
    )
    )
    (setq d (vlax-curve-getDistAtParam
      ent
      (vlax-curve-getEndParam ent)
    ))
    (list d (entlast))
  )
  ;;;routine ...
  (setq l (my-getpt))
  (setq rs1 (foo l))
  (setq rs2 (foo (mapcar (function (lambda (x)
     (gsls-XY->R x (/ pi -2.))
   ))
l
);_rotate pts by -pi/2 , cal the TSP polyline again .
    ))
  (cond ((<= (car rs1) (car rs2))
(entdel (cadr rs2))
(princ (strcat "\nPolyline Length: " (rtos (car rs1) 2 4) " mm."))
)
(t
(setq obj (vlax-ename->vla-object (cadr rs2)))
(vla-TransformBy  obj
   (vlax-tmatrix
     '((0. 1. 0. 0.)
       (-1. 0. 0. 0.)
       (0. 0. 1.0 0.)
       (0. 0. 0. 1.0)
      )))
(vlax-release-object obj)
(entdel (cadr rs1))
(princ (strcat "\nPolyline Length: " (rtos (car rs2) 2 4) " mm.") )
)
  )
  (princ)
)
dear sir,
error in lisp, using autocad 2006
Command: tsp ; error: no function definition: MY-GETPT
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on March 29, 2011, 03:46:38 AM
dear sir,
error in lisp, using autocad 2006
Command: tsp ; error: no function definition: MY-GETPT
Hi , Sam
Please use this one.It has been included all the function.Although it is not so perfect,I think.
Title: Re: Need your help,Object Connect&Draw pline
Post by: Sam on March 29, 2011, 04:40:43 AM
dear sir,
error in lisp, using autocad 2006
Command: tsp ; error: no function definition: MY-GETPT
Hi , Sam
Please use this one.It has been included all the function.Although it is not so perfect,I think.
dear sir,
thx for reply
it's working
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on April 01, 2011, 03:43:39 PM
it's a GA method , so it maybe a wrong result .
Which result do you want ? Pleat lay out .
if you just want Horizontal and vertical lines connection, you can add cond in it .
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on April 01, 2011, 09:31:02 PM
it's a GA method , so it maybe a wrong result .
Which result do you want ? Pleat lay out .
if you just want Horizontal and vertical lines connection , you can add cond in it .

Yes, I need Horizontal and vertical lines connection .But it appeared cross lines connection sometimes as reply#21 described with using your code.
How do I add cond ? Need further help.
Thanks!
Title: Re: Need your help,Object Connect&Draw pline
Post by: SOFITO_SOFT on April 02, 2011, 02:46:11 PM
Hello: Exciting TSP .  :lol: :lol: :lol: Greetings :-)
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on April 02, 2011, 08:51:38 PM
Serious Support !
H/V connections is easy to get , just help yourself .
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on April 05, 2011, 08:46:31 PM
Serious Support !
H/V connections is easy to get , just help yourself .

OK,I will try it this afternoon.I hope that it is as simple as you say.
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on April 10, 2011, 09:39:59 PM
Hi,chlh_jd
I failed once again,even though I've try my best.
So I post my sample dwg to clarify.
The red polyline is what I got from using your code ,and the yellow one is what I what.
Please,check it for me.
xia
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on April 11, 2011, 03:13:38 AM
today have no time to do much . see the gif
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on April 11, 2011, 04:11:56 AM
excellent! Nice solution!
Keep watching...
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on April 11, 2011, 01:26:42 PM
here's A e.g. 
Code: [Select]
;;; function : to union rectangulars with a given span range
;;; the span(dis) must be a number which can connect wanted rects  and don't connect rects you do not want .
;;; so it's just a way for example , to suit for all conds you must take the span [from ~ to] into recursion .
;;; by GSLS(SS) 2011-4-12
;;;
(defun c:test (/ dis ss ssobj doc ms os ob a b pda)
  (or dis
      (setq dis (getreal "\nPlease input joined max-distance<25>:"))
      (setq dis 25.)
  ) ;_here is just a way , it must be [from ~ to] to check is suit for . 
  (setq ssobj (ss2lst (ssget '((0 . "LWPOLYLINE"))) T))
  (setq os (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq doc (vla-get-activedocument
      (vlax-get-acad-object)
    )
ms  (vla-get-modelspace doc)
ob  nil
ss  (ssadd)
  )
  (foreach a ssobj
    (setq b (ss-Offset a (- dis)))
    (if (not (vl-catch-all-error-p b))
      (progn
(setq b (car
  (vlax-safearray->list
    (vlax-variant-value
      b
    )
  )
)
)
(vla-addregion
  ms
  (vlax-safearray-fill
    (vlax-make-safearray vlax-vbObject '(0 . 0))
    (list b)
  )
)
(if (vlax-erased-p b)
  nil
  (vla-delete b)
)
(setq ss (ssadd (entlast) ss))
      )
    )
  )
  (command "union" ss "")
  (command "explode" (entlast))
  (setq ss (ssget "p"))
  (vl-catch-all-apply
    (quote
      (lambda nil
(if (setq pda (getvar "peditaccept"))
  (progn
    (setvar "peditaccept" 1)
    (command "_pedit" "m" ss "" "j" "j" "b" 1e-6 "")
    (setvar "peditaccept" pda)
  )
  (command "_pedit" "m" ss "" "y" "j" "j" "b" 1e-6 "")
)
      )
    )
  )
  (ss-Offset (setq b (vlax-ename->vla-object (entlast))) dis)
  (vla-delete b)
  (setvar "OSMODE" os)
  (princ)
)
;;
;;
(defun ss-Offset (obj d / b p ret)
  (cond
    ((= "16" (substr (getvar "acadver") 1 2))
     (setq p (vlax-3D-point (vlax-curve-getstartpoint obj)))
     (vla-move obj p (vlax-3D-point (list 0 0 0)))
     (setq ret (VL-CATCH-ALL-APPLY (quote vla-Offset) (list obj d)))
     (vla-move obj (vlax-3D-point (list 0 0 0)) p)
     (if (not (vl-catch-all-error-p ret))
       (vla-move (car (vlax-safearray->list (vlax-variant-value ret)))
(vlax-3D-point (list 0 0 0))
p
       )
     )
     ret
    )
    (t
     (VL-CATCH-ALL-APPLY (quote vla-Offset) (list obj d))
    )
  )
)
(defun ss2lst (ss vla / a e i)
  (setq i -1)
  (while (setq e (ssname ss (setq i (1+ i))))
    (if vla
      (setq e (vlax-ename->vla-object e))
    )
    (setq a (cons e a))
  )
)
Title: Re: Need your help,Object Connect&Draw pline
Post by: chlh_jd on April 11, 2011, 01:37:36 PM
Keep watching...
It's your homework , not mines . so don't keep wathching ... get over by yourself until your 'Need your help' .    :|
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on April 11, 2011, 09:26:12 PM
Keep watching...
It's your homework , not mines . so don't keep wathching ... get over by yourself until your 'Need your help' .    :|
OK.Try it by myself.
Title: Re: Need your help,Object Connect&Draw pline
Post by: m4rdy on April 12, 2011, 02:00:31 PM
Code: [Select]
;;==========================================================
;; Original from Gile
;; modification from chlh_jd

(defun c:test1 (/ dist n ss ent lst pt p Minpt Maxpt pt1 ssad1 reg ss2 pda)
  (setq dist (getdist "\nMax distance :")
ssadd1 nil
reg nil
ss2 nil)
  (if (setq n  -1
    ;;ss (ssget '((0 . "POINT")));_==>> extracted from polylines
    ss (ssget '((0 . "LWPOLYLINE")))
      )
    (while (setq ent (ssname ss (setq n (1+ n))))
      (setq lst (append (polycoords ent) lst))
    )
  )
  (setq ssad1 (ssadd))
  (while lst
    (setq pt  (car lst)
  lst (cdr lst)
    )
    (foreach p lst
      (if (and (<= (distance pt p) dist)
       (/= (distance pt p) 0.00)
       (or (equal (MeCalcTheta pt p) 90.0)
   (equal (MeCalcTheta pt p) 0.0)
   (equal (MeCalcTheta pt p) 180.0)
   (equal (MeCalcTheta pt p) 270.0)
       )
  )
(progn
(entmake (list '(0 . "LINE") (cons 10 pt) (cons 11 p)))
(ssadd (entlast) ssad1))
      )
    )
  );_end while
  (vl-cmdf "region" ssad1 "")
  (princ "SELECT AGAIN ")
  (setq reg (ssget '((0 . "REGION"))));_==> i'm sure there's another better way
  (vl-cmdf "erase" ssad1 "")
  (vl-cmdf "union" reg "")
  (command "explode" (entlast))
  (setq ss2 (ssget "p"))
  (vl-catch-all-apply
    (quote
      (lambda nil
(if (setq pda (getvar "peditaccept"))
  (progn
    (setvar "peditaccept" 1)
    (command "_pedit" "m" ss2 "" "j" "j" "b" 1e-6 "")
    (setvar "peditaccept" pda)
  )
  (command "_pedit" "m" ss2 "" "y" "j" "j" "b" 1e-6 "")
)
      )
    )
  )
);_defun

;; Jurg menzi
(defun MeCalcTheta (Pt1 Pt2 / X__Abs Y__Abs X__Dif Y__Dif TheVal)
 (setq X__Dif (- (car Pt2) (car Pt1))
       Y__Dif (- (cadr Pt2) (cadr Pt1))
       X__Abs (abs X__Dif)
       Y__Abs (abs Y__Dif)
       TheVal (if (equal (+ X__Abs Y__Abs) 0.0 1E-8)
               0.0
               (/ Y__Dif (+ X__Abs Y__Abs))
              )
 )
 (if (< X__Dif 0)
  (setq TheVal (- 2.0 TheVal))
  (if (< Y__Dif 0) (setq TheVal (+ 4.0 TheVal)))
 )
 (* 90.0 TheVal)
)

;; Get coordinate
;; using vlax-curve* functions.
;; Works with all curve polylines types (lw, 2d, 3d) returns WCS coordinates.
;; Gile
;; http://www.cadtutor.net/forum/showthread.php?51700-Vertices-of-a-Polyline

(defun polyCoords (pl / n l)
  (vl-load-com)
  (setq pl (vlax-ename->vla-object pl))
  (setq n (if (vlax-curve-IsClosed pl)
            (fix (vlax-curve-getEndParam pl))
            (1+ (fix (vlax-curve-getEndParam pl)))
          )
  )
  (while (/= 0 n)
    (setq l (cons (vlax-curve-getPointAtParam pl (setq n (1- n))) l))
  )
)

i'm still learning (and lurking..  :-D) vlisp.

m4rdy
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on April 12, 2011, 11:29:49 PM
i'm still learning (and lurking..  :-D) vlisp.
m4rdy
Hi,m4rdy
It works. But surplus region has not been deleted.
BTW,I will show my code this afternoon.
Title: Re: Need your help,Object Connect&Draw pline
Post by: m4rdy on April 13, 2011, 01:22:42 AM
Hi,m4rdy
It works. But surplus region has not been deleted.
BTW,I will show my code this afternoon.

In your case from post #31 it works fine.
Or do you have other dwg for test?
Let me know.

m4rdy
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on April 13, 2011, 02:31:53 AM
Hi,m4rdy
The surplus region has not been deleted,as my animation that has been posted.
And how can I decide the max distance in your code?
I used "25" in my sample dwg from post #31 ,then it's OK.
If I used "50" ,the result is not the same.

xia
Title: Re: Need your help,Object Connect&Draw pline
Post by: xiaxiang on April 13, 2011, 02:39:50 AM
So I post my code even it is ugly and Imperfect.
For the reason of proving I've done something for my homework.
Special Thanks to chlh_jd . :-)
Title: Re: Need your help,Object Connect&Draw pline
Post by: m4rdy on April 13, 2011, 07:22:11 AM
I guess you've missed the second selection on "SELECT AGAIN"

Quote
And how can I decide the max distance in your code?
It can be the largest between the distance of plines or length of pline segments.

or am i missing something here?

m4rdy