TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: bprabhakar001 on August 25, 2006, 11:49:32 PM
-
Dear All,
I have a written a program to identify the vertices which are not identical from overlapping each polylines.
But it gives peculate result. I did not have where exactly problem exist.
Would you please some one help me to rectify the problem. And also I requesting you please suggest the method to solve this. Because if the dwg having more data it was taking couple of processing time some time hanging also.
I am very glad to here the corrections.
Thanking U,
Prabhakar.B
<contact information removed>
-
(defun c:test-lw (/ a1 a2 l)
(if (and (setq a1 (ssget "_X" '((0 . "POLYLINE,LWPOLYLINE") (8 . "*Trails Routes_*"))))
(setq a2 (ssget "_X" '((0 . "POLYLINE,LWPOLYLINE") (8 . "*Trails_*"))))
) ;_ and
(progn
(setq a1 (mapcar (function cadr) (ssnamex a1))
a2 (mapcar (function cadr) (ssnamex a2))
) ;_ setq
(progn
(foreach x a1
(foreach x1 a2
(if
(and (equal (distance (vlax-curve-getclosestpointto x (vlax-curve-getStartPoint x1))
(vlax-curve-getStartPoint x1)
) ;_ distance
0.
1e-8
) ;_ equal
(equal (distance (vlax-curve-getclosestpointto x (vlax-curve-getEndPoint x1))
(vlax-curve-getEndPoint x1)
) ;_ distance
0.
1e-8
) ;_ equal
) ;_ and
(progn
(setq a2 (vl-remove x1 a2))
(foreach x2 (mapcar
(function cdr)
(vl-remove-if-not (function (lambda (b) (= (car b) 10))) (entget x1))
) ;_ mapcar
(if (not (equal (distance (vlax-curve-getclosestpointto x x2) x2)
0.
1e-8
) ;_ equal
) ;_ not
(setq l (cons x2 l))
) ;_ if
) ;_ foreach
) ;_ progn
) ;_ if
) ;_ foreach
) ;_ foreach
(foreach x a1
(foreach x2 l
(if (equal (distance (vlax-curve-getclosestpointto x x2) x2) 0. 1e-8)
(setq l (vl-remove x2 l))
) ;_ if
) ;_ foreach
) ;_ foreach
(foreach x l
(entmakex
(list
'(0 . "CIRCLE")
'(8 . "ERROR-DIST")
'(62 . 1)
(cons 10 x)
'(40 . 0.0005)
) ;_ list
) ;_ entmakex
) ;_ foreach
) ;_ progn
) ;_ progn
) ;_ if
(princ)
)
-
Evgeniy you beat me to it. :)
Here is my attempt.
(defun c:ver (/ echo osmode)
(vl-load-com)
(defun getlwpolylinecoords (ent / idx pt result)
(setq idx -1)
(while (setq pt (vlax-curve-getpointatparam ent (setq idx (1+ idx))))
(setq result (cons pt result))
)
(reverse result)
)
(defun get_vertex (lyr / ss coor result)
(if (setq ss (ssget "_X" (list '(0 . "POLYLINE,LWPOLYLINE") (cons 8 lyr))))
(mapcar '(lambda (x)
(if (setq coor (getlwpolylinecoords x))
(if result
(setq result (append coor result))
(setq result coor)
)
)
)
(mapcar 'cadr
(ssnamex ss)
)
)
)
result
)
;; Subtract two point list given a max distance
;; CAB 08/26/2006
(defun return_unique_points (lst1 lst2 max_distance / tmp)
(setq tmp lst2)
(mapcar
'(lambda (x)
(setq lst2 (vl-remove-if '(lambda (y) (< (distance x y) max_distance)) lst2))
)
lst1
)
(mapcar
'(lambda (x)
(setq lst1 (vl-remove-if '(lambda (y) (< (distance x y) max_distance)) lst1))
)
tmp
)
(append lst2 lst1)
)
(defun mark (lst r)
(mapcar
'(lambda (pt)
(entmake
(list (cons 0 "CIRCLE")
(cons 6 "BYLAYER")
(cons 8 "ERROR")
(cons 10 pt)
(cons 40 r)
(cons 62 1) ; RED
(cons 210 (list 0.0 0.0 1.0))
)
)
)
lst
)
)
;;------------------------------------------
;; Begin Here
;;------------------------------------------
(command "undo" "be")
(setq echo (getvar "cmdecho")
osmode (getvar "osmode")
)
(setvar "CMDECHO" 0)
(setvar "OSMODE" 0)
(setq rad 0.0004) ; Circle for test
(setq max_dist 0.0000001) ; ** max distance for error of points
(if
(and
(or (setq trail (get_vertex "*TRAIL*"))
(prompt "\nNo trail features selected\n")
)
(or (setq route (get_vertex "*ROUTE*"))
(prompt "\nNo route features selected\n")
)
)
(progn
(prompt "\n * * * Working, Please Wait........\n")
(if (setq mis_match (return_unique_points trail route max_dist))
(mark mis_match rad)
)
)
)
(setvar "CMDECHO" echo)
(setvar "OSMODE" osmode)
(command "undo" "end")
(princ)
)
;;===============================================================================;;
(repeat 3 (print))
(princ
"\n\t\lsp loaded.............Proceed with \"VER\"."
)
(princ)
-
Evgeniy you beat me to it. :)
Here is my attempt.
Excuse! I did not wish to offend. :-(
I probably have hastened, I needed to wait for all a floor of hour...
-
Evgeniy
You did not offend me. I was joking around.
I enjoy all your post and learn from them, thanks for participating, and keep up the good work.
Alan
-
Evgeniy
You did not offend me. I was joking around.
I enjoy all your post and learn from them, thanks for participating, and keep up the good work.
Alan
Alan
I too study, but already for you! :-)
-
Thanking you both,
Mr. Cab your program is giving exact results what am I trying.
At the same time Mr.ElpanovEvgeniy program is running with superb fast. But it was giving errors only where trail vertex differing.
It is fails when overlapping route missing/extra vertex in route list.
Thanking you very much. I am trying to get such a speed from ElpanovEvgeniy program and the desired results from Mr. Cab.
I requesting you please guide me.
Thanking you,
Prabhakar.B
-
Thanking you both,
Mr. Cab your program is giving exact results what am I trying.
At the same time Mr.ElpanovEvgeniy program is running with superb fast. But it was giving errors only where trail vertex differing.
It is fails when overlapping route missing/extra vertex in route list.
Thanking you very much. I am trying to get such a speed from ElpanovEvgeniy program and the desired results from Mr. Cab.
I requesting you please guide me.
Thanking you,
Prabhakar.B
:-)
(defun c:test-lw (/ a1 a2 x)
(if (and (setq a1 (ssget "_X" '((0 . "POLYLINE,LWPOLYLINE") (8 . "*Trails Routes_*"))))
(setq a2 (ssget "_X" '((0 . "POLYLINE,LWPOLYLINE") (8 . "*Trails_*"))))
) ;_ and
(progn
(setq a1 (mapcar (function cadr) (ssnamex a1))
a2 (mapcar
(function
(lambda (x / e i l)
(setq e (vlax-curve-getEndParam x)
i 0
) ;_ setq
(while (< i e)
(setq l (cons (vlax-curve-getPointAtParam x i) l)
i (+ i 0.5)
) ;_ setq
) ;_ while
l
) ;_ lambda
) ;_ function
(mapcar (function cadr) (ssnamex a2))
) ;_ mapcar
) ;_ setq
(foreach x a1
(setq a2
(vl-remove-if
(function null)
(mapcar
(function
(lambda (x2)
(while
(and
(car x2)
(equal (distance (vlax-curve-getclosestpointto x (car x2))
(car x2)
) ;_ distance
0.
1e-8
) ;_ equal
) ;_ and
(setq x2 (cdr x2))
) ;_ while
(vl-remove-if (function null) x2)
) ;_ lambda
) ;_ function
a2
) ;_ mapcar
) ;_ vl-remove-if
) ;_ setq
) ;_ foreach
(setq a2 (apply (function append) a2))
(foreach x a1
(foreach x2 a2
(if (equal (distance (vlax-curve-getclosestpointto x x2) x2) 0. 1e-8)
(setq a2 (vl-remove x2 a2))
) ;_ if
) ;_ foreach
) ;_ foreach
(foreach x a2
(entmakex
(list
'(0 . "CIRCLE")
'(8 . "ERROR-DIST")
'(62 . 1)
(cons 10 x)
'(40 . 0.0005)
) ;_ list
) ;_ entmakex
) ;_ foreach
) ;_ progn
) ;_ if
(princ)
)
-
Wow !!! You guys are good !!! :kewl:
-
Dear All,
I am afraid am unable to find the some of the attached referenced dwg.
I requesting you please kindly resolve that.
Thanking you,
Prabhakar.B
-
Dear All,
I am afraid am unable to find the some of the attached referenced dwg.
I requesting you please kindly resolve that.
Thanking you,
Prabhakar.B
Only as an example...
(defun c:test-lw (/ A1 A2 P X)
(if (and (setq a1 (ssget "_X" '((0 . "POLYLINE,LWPOLYLINE") (8 . "*Trails Routes_*"))))
(setq a2 (ssget "_X" '((0 . "POLYLINE,LWPOLYLINE") (8 . "*Trails_*"))))
)
(foreach x (del-pt1
(mapcar
(function cdr)
(vl-remove-if-not
(function
(lambda (b)
(= (car b) 10)
) ;_ lambda
) ;_ function
(apply
(function append)
(mapcar
(function entget)
(mapcar (function cadr) (ssnamex a1))
) ;_ mapcar
) ;_ apply
) ;_ vl-remove-if-not
) ;_ mapcar
(mapcar
(function cdr)
(vl-remove-if-not
(function
(lambda (b)
(= (car b) 10)
) ;_ lambda
) ;_ function
(apply
(function append)
(mapcar
(function entget)
(mapcar (function cadr) (ssnamex a2))
) ;_ mapcar
) ;_ apply
) ;_ vl-remove-if-not
) ;_ mapcar
) ;_ del-pt1
(entmakex
(list
'(0 . "CIRCLE")
'(8 . "ERROR-DIST")
'(62 . 1)
(cons 10 x)
'(40 . 0.0005)
) ;_ list
) ;_ entmakex
) ;_ foreach
) ;_ if
(princ)
) ;_ defun
(defun del-pt1 (lst1 lst2)
(if (and lst1 lst2)
(if (vl-member-if
(function
(lambda (a)
(equal (distance (car lst2) a) 0. 1e-8)
) ;_ lambda
) ;_ function
lst1
) ;_ vl-member-if
(del-pt1
(vl-remove-if
(function
(lambda (a)
(equal (distance (car lst2) a) 0. 1e-8)
) ;_ lambda
) ;_ function
lst1
) ;_ vl-remove-if
(vl-remove-if
(function
(lambda (a)
(equal (distance (car lst2) a) 0. 1e-8)
) ;_ lambda
) ;_ function
(cdr lst2)
) ;_ vl-remove-if
) ;_ del-pt1
(cons
(car lst2)
(del-pt1
(vl-remove-if
(function
(lambda (a)
(equal (distance (car lst2) a) 0. 1e-8)
) ;_ lambda
) ;_ function
lst1
) ;_ vl-remove-if
(vl-remove-if
(function
(lambda (a)
(equal (distance (car lst2) a) 0. 1e-8)
) ;_ lambda
) ;_ function
(cdr lst2)
) ;_ vl-remove-if
) ;_ del-pt1
) ;_ cons
) ;_ if
(if (or lst1 lst2)(append lst1 lst2))
) ;_ if
) ;_ defun
-
Great, I appreciate your efforts. I don’t' know how can I useful for u my friend.
Thanking you very much you and to this Org.
I will upload all the source code what am I having since 6 years. Any one could help to commenting or functions separation is welcome.
Best Regards,
Prabhakar.B
-
Great, I appreciate your efforts. I don’t' know how can I useful for u my friend.
Thanking you very much you and to this Org.
I will upload all the source code what am I having since 6 years. Any one could help to commenting or functions separation is welcome.
Best Regards,
Prabhakar.B
I today have spent only 10 minutes for your problem... :-o