Crossing Angle
Please upload more complex sample to save yourself from answering to many questions.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Accepted solution
Before you update some more applicable sample here is a major part of code you are looking for. Following code creates a list as follows. If there is some good soul, he will create update to my function that populates a table object from data received in a list. If not, you will have to wait till I have time to finish it
((117.075 "135" "0") (198.065 "75" "ASP ROAD") (235.485 "102" "0") (302.381 "75" "Canal") (421.4 "48" "0") (540.234 "78" "0"))
So here is the code. It is made with presumption that all crossing elements are non elevated lwpolylines. In some situation you may have to reverse polyline if distances don't match. It works correct on a sample you've provided.
(defun c:pia ( / sort keyValue rad_to_deg deg_to_rad vector vect_dot vect_mod create_value_vector unit_vect asin acos vectorSide lwpolysections
cdist pipeline ss_cross npoints ent i pts e seg ip di v1 v2 e ang ret *error*)
(vl-load-com)
(defun *error* () (princ))
(defun sort (lst) (vl-sort lst '(lambda (p1 p2)(< (car p1)(car p2)))))
(defun keyValue (key el)(cdr (assoc key el)))
(defun rad_to_deg (rad)(* 180.0 (/ rad PI)))
(defun deg_to_rad (deg)(* PI (/ deg 180.0)))
(defun vector (p1 p2) (mapcar '- p2 p1))
(defun vect_dot (v1 v2)(apply '+ (mapcar '* v1 v2)))
(defun v+ (v1 v2)(mapcar '+ v1 v2))
(defun v- (v1 v2)(mapcar '- v1 v2))
(defun vect_mod (v)(sqrt(vect_dot v v)))
(defun create_value_vector (n val / r ) (repeat n (setq r (cons val r))) r)
(defun unit_vect (v)(mapcar '* v (create_value_vector (length v) (/ 1 (vect_mod v)))))
(defun asin (x)
(cond
((and(> x -1.0)(< x 1.0)) (atan (/ x (sqrt (- 1.0 (* x x))))))
((= x -1.0) (* -1.0 (/ pi 2)))
((= x 1) (/ pi 2))
)
)
(defun acos (x)(cond ((and(>= x -1.0)(<= x 1.0)) (-(* pi 0.5) (asin x)))))
(defun vectorSide (v1 v2 p / r *fuzz*)
(setq r (- (* (-(car v2)(car v1))(-(cadr p)(cadr v1)))
(* (-(cadr v2)(cadr v1))(-(car p)(car v1)))
)
*fuzz* 1e-10
)
(cond ((equal r 0.0 *fuzz*) 0) (t (fix (/ (abs r) r))))
)
(defun lwpolysections(e start end / ent npoints elev pts pset p1 p2 i v1 v2);
(setq ent (entget e) pts (list))
(if (and ent)
(progn
(setq npoints (keyValue 90 ent) npoints (fix npoints) elev (keyValue 38 ent) i 0)
(repeat (length ent)(setq pp (nth i ent))(if (eq (car pp) 10) (setq pts (append pts (list (cdr pp))))) (setq i (+ i 1)))
(if (eq (keyValue 70 ent) 1)
(setq pts (cdr (reverse pts)) pts (reverse pts) npoints (- npoints 1)) ; closed lwpoly
)
(setq i 0)
(repeat (- npoints 1)
(setq p1 (nth i pts) p2(nth (+ i 1) pts))
(if (and v2) (setq v1 v2 v2 (vectorSide start end p2))(setq v1 (vectorSide start end p1) v2 (vectorSide start end p2)))
(if (not (eq v1 v2))(setq pset(append pset (list(list p1 p2 (cdr (assoc 8 ent )))))))
(setq i (+ i 1))
)
)
)
pset
)
(setq cdist 0 i 0)
(setq pipeline (car(entsel "\nSelect pipeline >")) ent (entget pipeline))
(setq ss_cross (ssget "x" (list '(0 . "lwpolyline") '(-4 . "<not")'(8 . "Proposed Pipeline") '(-4 . "not>"))))
(repeat (length ent)(setq pp (nth i ent))(if (= (car pp) 10) (setq pts (cons (cdr pp) pts))) (setq i (+ i 1)))
(setq pts (reverse pts) i 0 j 0)
(repeat (- (length pts) 1)
(setq start (nth i pts) end (nth (+ i 1) pts))
(setq ss_cross (ssget "F" (list start end) (list '(0 . "lwpolyline") '(-4 . "<not")'(8 . "Proposed Pipeline") '(-4 . "not>"))))
(if ss_cross
(progn
(repeat (sslength ss_cross)
(setq int_segs (lwpolysections (ssname ss_cross j) start end))
(foreach e int_segs
(setq e (car int_segs) int_segs (cdr int_segs))
(setq p1 (car e) p2 (cadr e) name (last e))
(setq ip (inters start end p1 p2 T))
(setq di (+ (distance start ip) cdist))
(setq v1 (vector ip start) v2 (vector ip p2))
(setq ang (rtos (rad_to_deg(acos (/ (vect_dot v1 v2) (* ( vect_mod v1)(vect_mod v2))))) 2 0))
(setq ret (cons (list di ang name) ret))
)
(setq j (+ j 1))
)
(if (< i (- (length pts) 1)) (setq cdist (+ cdist (distance start end))))
)
(if (< i (- (length pts) 1)) (setq cdist (+ cdist (distance start end))))
)
(setq i (+ i 1) j 0 )
)
(setq ret (sort ret))
)
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
I didn't have a time to do all this stuff but will do it today if possible. But just with this code he can do all the rest.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Accepted solution
Here is final code that enables you to create acad table, write to txt file, or both.
(defun c:pia ( / sort keyValue rad_to_deg deg_to_rad vector vect_dot vect_mod create_value_vector unit_vect asin acos vectorSide lwpolysections
cdist pipeline ss_cross npoints ent i pts e a seg ip di v1 v2 e ang ret *error* table row *acdoc*)
(vl-load-com)
(or *acdoc* (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object))))
(defun *error* () (princ))
(defun sort (lst) (vl-sort lst '(lambda (p1 p2)(< (cadr p1)(cadr p2)))))
(defun keyValue (key el)(cdr (assoc key el)))
(defun rad_to_deg (rad)(* 180.0 (/ rad PI)))
(defun deg_to_rad (deg)(* PI (/ deg 180.0)))
(defun vector (p1 p2) (mapcar '- p2 p1))
(defun vect_dot (v1 v2)(apply '+ (mapcar '* v1 v2)))
(defun v+ (v1 v2)(mapcar '+ v1 v2))
(defun v- (v1 v2)(mapcar '- v1 v2))
(defun vect_mod (v)(sqrt(vect_dot v v)))
(defun create_value_vector (n val / r ) (repeat n (setq r (cons val r))) r)
(defun unit_vect (v)(mapcar '* v (create_value_vector (length v) (/ 1 (vect_mod v)))))
(defun asin (x)
(cond
((and(> x -1.0)(< x 1.0)) (atan (/ x (sqrt (- 1.0 (* x x))))))
((= x -1.0) (* -1.0 (/ pi 2)))
((= x 1) (/ pi 2))
)
)
(defun acos (x)(cond ((and(>= x -1.0)(<= x 1.0)) (-(* pi 0.5) (asin x)))))
(defun vectorSide (v1 v2 p / r *fuzz*)
(setq r (- (* (-(car v2)(car v1))(-(cadr p)(cadr v1)))
(* (-(cadr v2)(cadr v1))(-(car p)(car v1)))
)
*fuzz* 1e-10
)
(cond ((equal r 0.0 *fuzz*) 0) (t (fix (/ (abs r) r))))
)
(defun lwpolysections(e start end / ent npoints elev pts pset p1 p2 i v1 v2);
(setq ent (entget e) pts (list))
(if (and ent)
(progn
(setq npoints (keyValue 90 ent) npoints (fix npoints) elev (keyValue 38 ent) i 0)
(repeat (length ent)(setq pp (nth i ent))(if (eq (car pp) 10) (setq pts (append pts (list (cdr pp))))) (setq i (+ i 1)))
(if (eq (keyValue 70 ent) 1)
(setq pts (cdr (reverse pts)) pts (reverse pts) npoints (- npoints 1)) ; closed lwpoly
)
(setq i 0)
(repeat (- npoints 1)
(setq p1 (nth i pts) p2(nth (+ i 1) pts))
(if (and v2) (setq v1 v2 v2 (vectorSide start end p2))(setq v1 (vectorSide start end p1) v2 (vectorSide start end p2)))
(if (not (eq v1 v2))(setq pset(append pset (list(list p1 p2 (cdr (assoc 8 ent )))))))
(setq i (+ i 1))
)
)
)
pset
)
(setq cdist 0 i 0)
(setq pipeline (car(entsel "\nSelect pipeline >")) ent (entget pipeline))
(setq ss_cross (ssget "x" (list '(0 . "lwpolyline") '(-4 . "<not")'(8 . "Proposed Pipeline") '(-4 . "not>"))))
(repeat (length ent)(setq pp (nth i ent))(if (= (car pp) 10) (setq pts (cons (cdr pp) pts))) (setq i (+ i 1)))
(setq pts (reverse pts) i 0 j 0)
(repeat (- (length pts) 1)
(setq start (nth i pts) end (nth (+ i 1) pts))
(setq ss_cross (ssget "F" (list start end) (list '(0 . "lwpolyline") '(-4 . "<not")'(8 . "Proposed Pipeline") '(-4 . "not>"))))
(if ss_cross
(progn
(repeat (sslength ss_cross)
(setq int_segs (lwpolysections (ssname ss_cross j) start end))
(foreach e int_segs
(setq e (car int_segs) int_segs (cdr int_segs))
(setq p1 (car e) p2 (cadr e) name (last e))
(setq ip (inters start end p1 p2 T))
(setq di (+ (distance start ip) cdist))
(setq v1 (vector ip start) v2 (vector ip p2))
(setq ang (rtos (rad_to_deg(acos (/ (vect_dot v1 v2) (* ( vect_mod v1)(vect_mod v2))))) 2 0))
(setq ret (cons (list name di ang ) ret))
)
(setq j (+ j 1))
)
(if (< i (- (length pts) 1)) (setq cdist (+ cdist (distance start end))))
)
(if (< i (- (length pts) 1)) (setq cdist (+ cdist (distance start end))))
)
(setq i (+ i 1) j 0 )
)
(setq ret (sort ret) i 0)
(initget 1 "yes no")
(if (= (getkword "\nWrite to acad table? (yes no) >") "yes")
(progn
(setq table (vla-addtable
(vla-get-modelspace *acdoc*)
(vlax-3d-point (getpoint "\nSelect table insertion point >"))
(+ 2 (length ret))
4 ; number of colums
5 ; cell height
30 ; row width
)
)
(vla-put-TitleSuppressed table :vlax-false)
(vla-put-HeaderSuppressed table :vlax-false)
(vla-setcelltextheight table 0 0 2.5)
(vla-setText table 0 0 "LIST OF ALL CROSSINGS FALLING ON THE ROUTE OF THE PIPELINE")
(repeat 4 (vla-setcelltextheight table 1 i 1.8) (setq i (1+ i)))
(vla-setText table 1 0 "Number")
(vla-setText table 1 1 "Type of crossing")
(vla-setText table 1 2 "Chainage (m)")
(vla-setText table 1 3 "Angle of crossing")
(setq row 2 i 0)
(foreach item ret
(repeat 4 (vla-setcelltextheight table row i 1.8) (vla-setCellAlignment table row i 5) (setq i (1+ i)))
(vla-settext table row 0 (- row 1))
(vla-settext table row 1 (car item))
(vla-settext table row 2 (rtos(cadr item) 2 2))
(vla-settext table row 3 (last item))
(setq row (1+ row) i 0)
)
)
)
(initget 1 "yes no")
(if (= (getkword "\nWrite to file? (yes no) >") "yes")
(progn
(setq f (getfiled "Exit file to write chainage:" (getvar "dwgprefix") "txt" 3))
(setq file1 (open f "w"))
(setq i 0)
(while (< i (length ret))
(setq row (nth i ret))
(setq n (itoa 1))
(setq type (car row))
(setq di (rtos (cadr row) 2 2))
(setq ang (last row))
(setq row (strcat n "," type "," di "," ang))
(write-line row file1)
(setq i ( 1+ i))
)
(princ "Done!")
(close file1)
(princ)
)
)
(princ)
)
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
At the moment I don't have a time to test it, will try to do it during the weekend. In your drawings try to use only lwpolylines and layer names should be identical to sample drawing provided above. You have a task to check out on what intersections code produces an error. This code was written without thorough checking, but a guess it may be usefull. As with any code you have to check final result and make changes if necesary.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Here is a sheme that describe how code works. In reality it only takes one situation (one angle), while actually there are two, and there is a cross similarity .I'll have to update code to calculate both angles. Actually we have to decide to show angles from either left or right side.
Proposal: imagine that we move along the section line and on crossing, we treat sectionline to have first point on a right side to section line. We have to decide for one of options.
At the moment code calculates angle between vectors x-1 and x-b.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Here is updated script. I hope that will now work correctly.
(defun c:pia ( / sort keyValue rad_to_deg deg_to_rad vector vect_dot vect_mod create_value_vector unit_vect asin acos vectorSide lwpolysections
cdist pipeline ss_cross npoints ent i pts e a seg ip di v1 v2 e ang type n ret *error* table row *acdoc* tmp f file1)
(vl-load-com)
(or *acdoc* (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object))))
(defun *error* () (princ))
(defun sort (lst) (vl-sort lst '(lambda (p1 p2)(< (cadr p1)(cadr p2)))))
(defun keyValue (key el)(cdr (assoc key el)))
(defun rad_to_deg (rad)(* 180.0 (/ rad PI)))
(defun deg_to_rad (deg)(* PI (/ deg 180.0)))
(defun vector (p1 p2) (mapcar '- p2 p1))
(defun vect_dot (v1 v2)(apply '+ (mapcar '* v1 v2)))
(defun v+ (v1 v2)(mapcar '+ v1 v2))
(defun v- (v1 v2)(mapcar '- v1 v2))
(defun vect_mod (v)(sqrt(vect_dot v v)))
(defun create_value_vector (n val / r ) (repeat n (setq r (cons val r))) r)
(defun unit_vect (v)(mapcar '* v (create_value_vector (length v) (/ 1 (vect_mod v)))))
(defun asin (x)
(cond
((and(> x -1.0)(< x 1.0)) (atan (/ x (sqrt (- 1.0 (* x x))))))
((= x -1.0) (* -1.0 (/ pi 2)))
((= x 1) (/ pi 2))
)
)
(defun acos (x)(cond ((and(>= x -1.0)(<= x 1.0)) (-(* pi 0.5) (asin x)))))
(defun vectorSide (v1 v2 p / r *fuzz*)
(setq r (- (* (-(car v2)(car v1))(-(cadr p)(cadr v1)))
(* (-(cadr v2)(cadr v1))(-(car p)(car v1)))
)
*fuzz* 1e-10
)
(cond ((equal r 0.0 *fuzz*) 0) (t (fix (/ (abs r) r))))
)
(defun lwpolysections(e start end / ent npoints elev pts pset p1 p2 i v1 v2);
(setq ent (entget e) pts (list))
(if (and ent)
(progn
(setq npoints (keyValue 90 ent) npoints (fix npoints) elev (keyValue 38 ent) i 0)
(repeat (length ent)(setq pp (nth i ent))(if (eq (car pp) 10) (setq pts (append pts (list (cdr pp))))) (setq i (+ i 1)))
(if (eq (keyValue 70 ent) 1)
(setq pts (cdr (reverse pts)) pts (reverse pts) npoints (- npoints 1)) ; closed lwpoly
)
(setq i 0)
(repeat (- npoints 1)
(setq p1 (nth i pts) p2(nth (+ i 1) pts))
(if (and v2) (setq v1 v2 v2 (vectorSide start end p2))(setq v1 (vectorSide start end p1) v2 (vectorSide start end p2)))
(if (not (eq v1 v2))(setq pset(append pset (list(list p1 p2 (cdr (assoc 8 ent )))))))
(setq i (+ i 1))
)
)
)
pset
)
(setq cdist 0 i 0)
(setq pipeline (car(entsel "\nSelect pipeline >")) ent (entget pipeline))
;(setq ss_cross (ssget "x" (list '(0 . "lwpolyline") '(-4 . "<not")'(8 . "Proposed Pipeline") '(-4 . "not>"))))
(repeat (length ent)(setq pp (nth i ent))(if (= (car pp) 10) (setq pts (cons (cdr pp) pts))) (setq i (+ i 1)))
(setq pts (reverse pts) i 0 j 0)
(repeat (- (length pts) 1)
(setq start (nth i pts) end (nth (+ i 1) pts))
(setq ss_cross (ssget "F" (list start end) (list '(0 . "lwpolyline") '(-4 . "<not")'(8 . "Proposed Pipeline") '(-4 . "not>"))))
(if ss_cross
(progn
(repeat (sslength ss_cross)
(setq int_segs (lwpolysections (ssname ss_cross j) start end))
(foreach e int_segs
(setq e (car int_segs) int_segs (cdr int_segs))
(setq p1 (car e) p2 (cadr e) name (last e))
(if (= (vectorSide start end p1) -1) (setq tmp p1 p1 p2 p2 tmp))
(setq ip (inters start end p1 p2 T))
(if ip
(setq
di (+ (distance start ip) cdist)
v1 (vector ip start) v2 (vector ip p1)
ang (rtos (rad_to_deg(acos (/ (vect_dot v1 v2) (* ( vect_mod v1)(vect_mod v2))))) 2 0)
ret (cons (list name di ang ) ret)
)
)
)
(setq j (+ j 1))
)
(if (< i (- (length pts) 1)) (setq cdist (+ cdist (distance start end))))
)
(if (< i (- (length pts) 1)) (setq cdist (+ cdist (distance start end))))
)
(setq i (+ i 1) j 0 )
)
(setq ret (sort ret) i 0)
(initget 1 "yes no")
(if (= (getkword "\nWrite to acad table? (yes no) >") "yes")
(progn
(setq table (vla-addtable
(vla-get-modelspace *acdoc*)
(vlax-3d-point (getpoint "\nSelect table insertion point >"))
(+ 2 (length ret))
4 ; number of colums
5 ; cell height
30 ; row width
)
)
(vla-put-TitleSuppressed table :vlax-false)
(vla-put-HeaderSuppressed table :vlax-false)
(vla-setcelltextheight table 0 0 2.5)
(vla-setText table 0 0 "LIST OF ALL CROSSINGS FALLING ON THE ROUTE OF THE PIPELINE")
(repeat 4 (vla-setcelltextheight table 1 i 1.8) (setq i (1+ i)))
(vla-setText table 1 0 "Number")
(vla-setText table 1 1 "Type of crossing")
(vla-setText table 1 2 "Chainage (m)")
(vla-setText table 1 3 "Angle of crossing")
(setq row 2 i 0)
(foreach item ret
(repeat 4 (vla-setcelltextheight table row i 1.8) (vla-setCellAlignment table row i 5) (setq i (1+ i)))
(vla-settext table row 0 (- row 1))
(vla-settext table row 1 (car item))
(vla-settext table row 2 (rtos(cadr item) 2 2))
(vla-settext table row 3 (last item))
(setq row (1+ row) i 0)
)
)
)
(initget 1 "yes no")
(if (= (getkword "\nWrite to file? (yes no) >") "yes")
(progn
(setq f (getfiled "Exit file to write chainage:" (getvar "dwgprefix") "txt" 3))
(setq file1 (open f "w"))
(setq i 0)
(while (< i (length ret))
(setq row (nth i ret))
(setq n (itoa 1))
(setq type (car row))
(setq di (rtos (cadr row) 2 2))
(setq ang (last row))
(setq row (strcat n "," type "," di "," ang))
(write-line row file1)
(setq i ( 1+ i))
)
(princ "Done!")
(close file1)
(princ)
)
)
(princ)
)
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Change in script line
(if (= (vectorSide start end p1) -1) (setq tmp p1 p1 p2 p2 tmp))
with
(if (= (vectorSide start end p2) -1) (setq tmp p1 p1 p2 p2 tmp))
Test it, and report result
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
If this is it regarding angle direction I will also add line object as possible crossing object. I have updated code so now it can cope with object that are crossing our section object at different sections.
How long are your profiles? If you have this pipeline object divided in sections you obviously have to at stations - starting distance value.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.