0 Members and 1 Guest are viewing this topic.
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 .
(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 / 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)) )
(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))) ))
;;;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))
hi Xiaxiang , here is new version .Code: [Select](setq l (my-getpt))
(setq l (my-getpt))
See reply #6, in mine it's a large routine for "CIRCLE,*LINE*,POINT,ARC,ELLIPSE,TEXT" , and I uses it in structure , so it's bypass .
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 2006Command: tsp ; error: no function definition: MY-GETPT
Quote from: Sam on March 29, 2011, 03:24:40 AMdear sir,error in lisp, using autocad 2006Command: tsp ; error: no function definition: MY-GETPTHi , SamPlease use this one.It has been included all the function.Although it is not so perfect,I think.
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 .