Author Topic: Need your help,Object Connect&Draw pline  (Read 8740 times)

0 Members and 1 Guest are viewing this topic.

xiaxiang

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #15 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))
)

chlh_jd

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #16 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)))
  )
)

chlh_jd

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #17 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 .

chlh_jd

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #18 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)
)

xiaxiang

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #19 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.
 :-) :-) :-)

chlh_jd

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #20 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 .

xiaxiang

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #21 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:
万分感谢!

xiaxiang

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #22 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.

Sam

  • Bull Frog
  • Posts: 201
Re: Need your help,Object Connect&Draw pline
« Reply #23 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
Every time we waste electricity, we put our planet's future in the dark. Let's turn around our attiude and start saving power and our planet, before it's too late
http://www.theswamp.org/donate.html

xiaxiang

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #24 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.

Sam

  • Bull Frog
  • Posts: 201
Re: Need your help,Object Connect&Draw pline
« Reply #25 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
Every time we waste electricity, we put our planet's future in the dark. Let's turn around our attiude and start saving power and our planet, before it's too late
http://www.theswamp.org/donate.html

chlh_jd

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #26 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 .
« Last Edit: April 01, 2011, 03:46:40 PM by chlh_jd »

xiaxiang

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #27 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!

SOFITO_SOFT

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #28 on: April 02, 2011, 02:46:11 PM »
Hello: Exciting TSP .  :lol: :lol: :lol: Greetings :-)

chlh_jd

  • Guest
Re: Need your help,Object Connect&Draw pline
« Reply #29 on: April 02, 2011, 08:51:38 PM »
Serious Support !
H/V connections is easy to get , just help yourself .