Topic: Fix routine for further develop/testing...

[ribarm]

Hi,
I need perhaps, if someone knows to fix this code in order to test/debug further one of routine related with network path(s) length marking / description...
Checking routine is in folder .\network : lengths_along_pipe_trees.lsp...

Here is questioning code for fixing - second part (breakage into smaller arcs is not working) - checked point : p1/p2 vs reference arc entity - break point don't lie on reference arc - "circular path in its entirety" defined by the same arc orientation and position for unknown reasons...

Code - Auto/Visual Lisp: [Select]

1. (defun c:sphere_rnd-equatorial-circles_2_arcs ( / *error* v^v process1 process2 osm ucsf ss i ci cix o r cc ccx vec p1 p2 arc1 arc2 arcs a1x a2x )
2.  
3.   (vl-load-com)
4.  
5.   (defun *error* ( m )
6.     (if ucsf
7.       (if command-s
8.         (command-s "_.UCS" "_P")
9.         (vl-cmdf "_.UCS" "_P")
10.       )
11.     )
12.     (if (= 8 (logand 8 (getvar (quote undoctl))))
13.       (if command-s
14.         (command-s "_.UNDO" "_E")
15.         (vl-cmdf "_.UNDO" "_E")
16.       )
17.     )
18.     (if osm
19.       (setvar (quote osmode) osm)
20.     )
21.     (if cmd
22.       (setvar (quote cmdecho) cmd)
23.     )
24.     (if m
25.       (prompt m)
26.     )
27.     (princ)
28.   )
29.  
30.   (defun v^v ( u v )
31.     (list
32.       (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
33.       (- (* (caddr u) (car v)) (* (car u) (caddr v)))
34.       (- (* (car u) (cadr v)) (* (cadr u) (car v)))
35.     )
36.   )
37.  
38.   (defun process1 ( cir o p1 p2 / arc1 arc2 ) ; arcs - lexical global
39.     (if command-s
40.       (command-s "_.UCS" "_3P" o p2 (mapcar (function +) o (cdr (assoc 210 (entget cir)))))
41.       (vl-cmdf "_.UCS" "_3P" o p2 (mapcar (function +) o (cdr (assoc 210 (entget cir)))))
42.     )
43.     (if command-s
44.       (command-s "_.VPOINT" (mapcar (function +) (trans o 1 0) (trans (list 1.0 0.0 0.0) 1 0 t)) (trans o 1 0))
45.       (vl-cmdf "_.VPOINT" (mapcar (function +) (trans o 1 0) (trans (list 1.0 0.0 0.0) 1 0 t)) (trans o 1 0))
46.     )
47.     (if command-s
48.       (command-s "_.BREAK" cir (trans p1 0 1) (trans p2 0 1))
49.       (vl-cmdf "_.BREAK" cir (trans p1 0 1) (trans p2 0 1))
50.     )
51.     (setq arc1 (if (and cir (not (vlax-erased-p cir)) (= (cdr (assoc 0 (entget cir))) "ARC")) cir (entlast)))
52.     (if (mirror3d (ssadd arc1) "XY" o "N")
53.       (setq arc2 (entlast))
54.     )
55.     (if command-s
56.       (command-s "_.ZOOM" "_P")
57.       (vl-cmdf "_.ZOOM" "_P")
58.     )
59.     (if command-s
60.       (command-s "_.UCS" "_P")
61.       (vl-cmdf "_.UCS" "_P")
62.     )
63.     (setq arcs (cons arc1 arcs) arcs (cons arc2 arcs))
64.   )
65.  
66.   (defun process2 ( arc p o )
67.     (if (vlax-curve-getparamatpoint arc p)
68.       (progn
69.         (if command-s
70.           (command-s "_.VPOINT" p o)
71.           (vl-cmdf "_.VPOINT" p o)
72.         )
73.         (if command-s
74.           (command-s "_.BREAK" arc p "@")
75.           (vl-cmdf "_.BREAK" arc p "@")
76.         )
77.         (if command-s
78.           (command-s "_.ZOOM" "_P")
79.           (vl-cmdf "_.ZOOM" "_P")
80.         )
81.       )
82.     )
83.   )
84.  
85.   (setq cmd (getvar (quote cmdecho)))
86.   (setvar (quote cmdecho) 0)
87.   (setq osm (getvar (quote osmode)))
88.   (setvar (quote osmode) 0)
89.   (if (not (vl-member-if (function (lambda ( x ) (wcmatch x "geom3d.*"))) (arx)))
90.     (if (findfile "geom3d.crx")
91.       (arxload (findfile "geom3d.crx"))
92.       (if (findfile "geom3d.arx")
93.         (arxload (findfile "geom3d.arx"))
94.       )
95.     )
96.   )
97.   (if (= 8 (logand 8 (getvar (quote undoctl))))
98.     (if command-s
99.       (command-s "_.UNDO" "_E")
100.       (vl-cmdf "_.UNDO" "_E")
101.     )
102.   )
103.   (if command-s
104.     (command-s "_.UNDO" "_M")
105.     (vl-cmdf "_.UNDO" "_M")
106.   )
107.   (if (= 0 (getvar (quote worlducs)))
108.     (progn
109.       (if command-s
110.         (command-s "_.UCS" "_W")
111.         (vl-cmdf "_.UCS" "_W")
112.       )
113.       (setq ucsf t)
114.     )
115.   )
116.   (if (setq ss (ssget "_:L" (list (cons 0 "CIRCLE"))))
117.     (progn
118.       ;;; breakeage of random oriented equatorial circles to half circle arcs ;;;
119.       (repeat (setq i (sslength ss))
120.         (setq ci (ssname ss (setq i (1- i))))
121.         (if (and ci (not (vlax-erased-p ci)))
122.           (progn
123.             (setq cix (entget ci))
124.             (setq o (cdr (assoc 10 cix)))
125.             (setq r (cdr (assoc 40 cix)))
126.             (setq cc (ssname ss (setq i (1- i))))
127.             (if (and cc (not (vlax-erased-p cc)))
128.               (progn
129.                 (setq ccx (entget cc))
130.                 (setq vec (mapcar (function *) (v^v (cdr (assoc 210 cix)) (cdr (assoc 210 ccx))) (list r r r)))
131.                 (setq p1 (mapcar (function +) o vec))
132.                 (setq p2 (mapcar (function -) o vec))
133.                 (process1 ci o p1 p2)
134.                 (process1 cc o p1 p2)
135.               )
136.             )
137.           )
138.         )
139.       )
140.       ;;; half circle arcs breakage to smaller composing arcs at their intersections ;;;
141.       (foreach arc1 arcs
142.         (foreach arc2 (vl-remove arc1 arcs)
143.           (if
144.             (and
145.               arc1
146.               (not (vlax-erased-p arc1))
147.               arc2
148.               (not (vlax-erased-p arc2))
149.             )
150.             (progn
151.               (setq a1x (entget arc1))
152.               (setq a2x (entget arc2))
153.               (setq o (cdr (assoc 10 a1x)))
154.               (setq r (cdr (assoc 40 a1x)))
155.               (if (not (equal (cdr (assoc 210 a1x)) (cdr (assoc 210 a2x)) 1e-6))
156.                 (progn
157.                   (setq vec (mapcar (function *) (v^v (cdr (assoc 210 a1x)) (cdr (assoc 210 a2x))) (list r r r)))
158.                   (setq p1 (mapcar (function +) o vec))
159.                   (setq p2 (mapcar (function -) o vec))
160.                   (process2 arc1 p1 o)
161.                   (process2 arc1 p2 o)
162.                   (process2 arc2 p1 o)
163.                   (process2 arc2 p2 o)
164.                 )
165.               )
166.             )
167.           )
168.         )
169.       )
170.     )
171.   )
172.   (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
173.   (*error* nil)
174. )
175.  

Thanks, M.R.

[ribarm]

Much better, but still not all intersections are processed...

Code - Auto/Visual Lisp: [Select]

1. (defun c:sphere_rnd-equatorial-circles_2_arcs ( / *error* v^v process1 process2 osm ucsf ss i ci cix o r cc ccx vec p1 p2 arc1 arc2 arcs a1x a2x arcss )
2.  
3.   (vl-load-com)
4.  
5.   (defun *error* ( m )
6.     (if ucsf
7.       (if command-s
8.         (command-s "_.UCS" "_P")
9.         (vl-cmdf "_.UCS" "_P")
10.       )
11.     )
12.     (if (= 8 (logand 8 (getvar (quote undoctl))))
13.       (if command-s
14.         (command-s "_.UNDO" "_E")
15.         (vl-cmdf "_.UNDO" "_E")
16.       )
17.     )
18.     (if osm
19.       (setvar (quote osmode) osm)
20.     )
21.     (if cmd
22.       (setvar (quote cmdecho) cmd)
23.     )
24.     (if m
25.       (prompt m)
26.     )
27.     (princ)
28.   )
29.  
30.   (defun v^v ( u v )
31.     (list
32.       (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
33.       (- (* (caddr u) (car v)) (* (car u) (caddr v)))
34.       (- (* (car u) (cadr v)) (* (cadr u) (car v)))
35.     )
36.   )
37.  
38.   (defun process1 ( cir o p1 p2 / arc1 arc2 ) ; arcs - lexical global
39.     (if command-s
40.       (command-s "_.UCS" "_3P" o p2 (mapcar (function +) o (cdr (assoc 210 (entget cir)))))
41.       (vl-cmdf "_.UCS" "_3P" o p2 (mapcar (function +) o (cdr (assoc 210 (entget cir)))))
42.     )
43.     (if command-s
44.       (command-s "_.VPOINT" (mapcar (function +) (trans o 1 0) (trans (list 1.0 0.0 0.0) 1 0 t)) (trans o 1 0))
45.       (vl-cmdf "_.VPOINT" (mapcar (function +) (trans o 1 0) (trans (list 1.0 0.0 0.0) 1 0 t)) (trans o 1 0))
46.     )
47.     (if command-s
48.       (command-s "_.BREAK" cir (trans p1 0 1) (trans p2 0 1))
49.       (vl-cmdf "_.BREAK" cir (trans p1 0 1) (trans p2 0 1))
50.     )
51.     (setq arc1 (if (and cir (not (vlax-erased-p cir)) (= (cdr (assoc 0 (entget cir))) "ARC")) cir (entlast)))
52.     (if (mirror3d (ssadd arc1) "XY" o "N")
53.       (setq arc2 (entlast))
54.     )
55.     (if command-s
56.       (command-s "_.ZOOM" "_P")
57.       (vl-cmdf "_.ZOOM" "_P")
58.     )
59.     (if command-s
60.       (command-s "_.UCS" "_P")
61.       (vl-cmdf "_.UCS" "_P")
62.     )
63.     (if arc1
64.       (setq arcs (cons arc1 arcs))
65.     )
66.     (if arc2
67.       (setq arcs (cons arc2 arcs))
68.     )
69.   )
70.  
71.   (defun process2 ( arc p / par arc1 arc2 ax1 ax2 ) ; arcss - lexical global
72.     (setq par (vlax-curve-getparamatpoint arc (vlax-curve-getclosestpointto arc p)))
73.     (setq arc1 (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object arc))))
74.     (setq ax1 (entget arc1))
75.     (entupd
76.       (cdr
77.         (assoc -1
78.           (entmod
79.             (subst (cons 51 par) (assoc 51 ax1) ax1)
80.           )
81.         )
82.       )
83.     )
84.     (setq arc2 (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object arc))))
85.     (setq ax2 (entget arc2))
86.     (entupd
87.       (cdr
88.         (assoc -1
89.           (entmod
90.             (subst (cons 50 par) (assoc 50 ax2) ax2)
91.           )
92.         )
93.       )
94.     )
95.     (entdel arc)
96.     (setq arcss (cons arc1 arcss) arcss (cons arc2 arcss))
97.   )
98.  
99.   (setq cmd (getvar (quote cmdecho)))
100.   (setvar (quote cmdecho) 0)
101.   (setq osm (getvar (quote osmode)))
102.   (setvar (quote osmode) 0)
103.   (if (not (vl-member-if (function (lambda ( x ) (wcmatch x "geom3d.*"))) (arx)))
104.     (if (findfile "geom3d.crx")
105.       (arxload (findfile "geom3d.crx"))
106.       (if (findfile "geom3d.arx")
107.         (arxload (findfile "geom3d.arx"))
108.       )
109.     )
110.   )
111.   (if (= 8 (logand 8 (getvar (quote undoctl))))
112.     (if command-s
113.       (command-s "_.UNDO" "_E")
114.       (vl-cmdf "_.UNDO" "_E")
115.     )
116.   )
117.   (if command-s
118.     (command-s "_.UNDO" "_M")
119.     (vl-cmdf "_.UNDO" "_M")
120.   )
121.   (if (= 0 (getvar (quote worlducs)))
122.     (progn
123.       (if command-s
124.         (command-s "_.UCS" "_W")
125.         (vl-cmdf "_.UCS" "_W")
126.       )
127.       (setq ucsf t)
128.     )
129.   )
130.   (if (setq ss (ssget "_:L" (list (cons 0 "CIRCLE"))))
131.     (progn
132.       ;;; breakeage of random oriented equatorial circles to half circle arcs ;;;
133.       (repeat (setq i (sslength ss))
134.         (setq ci (ssname ss (setq i (1- i))))
135.         (if (and ci (not (vlax-erased-p ci)))
136.           (progn
137.             (setq cix (entget ci))
138.             (setq o (cdr (assoc 10 cix)))
139.             (setq r (cdr (assoc 40 cix)))
140.             (setq cc (ssname ss (setq i (1- i))))
141.             (if (and cc (not (vlax-erased-p cc)))
142.               (progn
143.                 (setq ccx (entget cc))
144.                 (setq vec (mapcar (function *) (v^v (cdr (assoc 210 cix)) (cdr (assoc 210 ccx))) (list r r r)))
145.                 (setq p1 (mapcar (function +) o vec))
146.                 (setq p2 (mapcar (function -) o vec))
147.                 (process1 ci o p1 p2)
148.                 (process1 cc o p1 p2)
149.               )
150.             )
151.           )
152.         )
153.       )
154.       ;;; half circle arcs breakage to smaller composing arcs at their intersections ;;;
155.       (while arcs
156.         (setq arcss nil)
157.         (foreach arc1 arcs
158.           (setq arcs (vl-remove arc1 arcs))
159.           (foreach arc2 arcs
160.             (if
161.               (and
162.                 arc1
163.                 (not (vlax-erased-p arc1))
164.                 arc2
165.                 (not (vlax-erased-p arc2))
166.               )
167.               (progn
168.                 (setq a1x (entget arc1))
169.                 (setq a2x (entget arc2))
170.                 (setq o (cdr (assoc 10 a1x)))
171.                 (setq r (cdr (assoc 40 a1x)))
172.                 (if (not (equal (cdr (assoc 210 a1x)) (cdr (assoc 210 a2x)) 1e-6))
173.                   (progn
174.                     (setq vec (mapcar (function *) (v^v (cdr (assoc 210 a1x)) (cdr (assoc 210 a2x))) (list r r r)))
175.                     (setq p1 (mapcar (function +) o vec))
176.                     (setq p2 (mapcar (function -) o vec))
177.                     (if
178.                       (and
179.                         arc1
180.                         (not (vlax-erased-p arc1))
181.                         (equal p1 (vlax-curve-getclosestpointto arc1 p1) 1e-3)
182.                         (not (equal p1 (vlax-curve-getstartpoint arc1) 1e-3))
183.                         (not (equal p1 (vlax-curve-getendpoint arc1) 1e-3))
184.                       )
185.                       (process2 arc1 p1)
186.                     )
187.                     (if
188.                       (and
189.                         arc2
190.                         (not (vlax-erased-p arc2))
191.                         (equal p1 (vlax-curve-getclosestpointto arc2 p1) 1e-3)
192.                         (not (equal p1 (vlax-curve-getstartpoint arc2) 1e-3))
193.                         (not (equal p1 (vlax-curve-getendpoint arc2) 1e-3))
194.                       )
195.                       (process2 arc2 p1)
196.                     )
197.                     (if
198.                       (and
199.                         arc1
200.                         (not (vlax-erased-p arc1))
201.                         (equal p2 (vlax-curve-getclosestpointto arc1 p2) 1e-3)
202.                         (not (equal p2 (vlax-curve-getstartpoint arc1) 1e-3))
203.                         (not (equal p2 (vlax-curve-getendpoint arc1) 1e-3))
204.                       )
205.                       (process2 arc1 p2)
206.                     )
207.                     (if
208.                       (and
209.                         arc2
210.                         (not (vlax-erased-p arc2))
211.                         (equal p2 (vlax-curve-getclosestpointto arc2 p2) 1e-3)
212.                         (not (equal p2 (vlax-curve-getstartpoint arc2) 1e-3))
213.                         (not (equal p2 (vlax-curve-getendpoint arc2) 1e-3))
214.                       )
215.                       (process2 arc2 p2)
216.                     )
217.                   )
218.                 )
219.               )
220.             )
221.           )
222.         )
223.         (setq arcs arcss)
224.       )
225.     )
226.   )
227.   (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
228.   (*error* nil)
229. )
230.  

If someone is willing to step in, I'll be very grateful...
M.R.

[ribarm]

I get just slightly more arcs, but still not like it should be...
Second part is problematic : under ;;; half circle arcs breakage to smaller composing arcs at their intersections ;;; comment...

Code - Auto/Visual Lisp: [Select]

1. (defun c:sphere_rnd-equatorial-circles_2_arcs ( / *error* v^v process1 process2 osm ucsf ss i ci cix o r cc ccx vec p1 p2 arc1 arc2 arcs arcsp a1x a2x arcss aarcs )
2.  
3.   (vl-load-com)
4.  
5.   (defun *error* ( m )
6.     (if ucsf
7.       (if command-s
8.         (command-s "_.UCS" "_P")
9.         (vl-cmdf "_.UCS" "_P")
10.       )
11.     )
12.     (if (= 8 (logand 8 (getvar (quote undoctl))))
13.       (if command-s
14.         (command-s "_.UNDO" "_E")
15.         (vl-cmdf "_.UNDO" "_E")
16.       )
17.     )
18.     (if osm
19.       (setvar (quote osmode) osm)
20.     )
21.     (if cmd
22.       (setvar (quote cmdecho) cmd)
23.     )
24.     (if m
25.       (prompt m)
26.     )
27.     (princ)
28.   )
29.  
30.   (defun v^v ( u v )
31.     (list
32.       (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
33.       (- (* (caddr u) (car v)) (* (car u) (caddr v)))
34.       (- (* (car u) (cadr v)) (* (cadr u) (car v)))
35.     )
36.   )
37.  
38.   (defun process1 ( cir o p1 p2 / arc1 arc2 ) ; arcs - lexical global
39.     (if command-s
40.       (command-s "_.UCS" "_3P" o p2 (mapcar (function +) o (cdr (assoc 210 (entget cir)))))
41.       (vl-cmdf "_.UCS" "_3P" o p2 (mapcar (function +) o (cdr (assoc 210 (entget cir)))))
42.     )
43.     (if command-s
44.       (command-s "_.VPOINT" (mapcar (function +) (trans o 1 0) (trans (list 1.0 0.0 0.0) 1 0 t)) (trans o 1 0))
45.       (vl-cmdf "_.VPOINT" (mapcar (function +) (trans o 1 0) (trans (list 1.0 0.0 0.0) 1 0 t)) (trans o 1 0))
46.     )
47.     (if command-s
48.       (command-s "_.BREAK" cir (trans p1 0 1) (trans p2 0 1))
49.       (vl-cmdf "_.BREAK" cir (trans p1 0 1) (trans p2 0 1))
50.     )
51.     (setq arc1 (if (and cir (not (vlax-erased-p cir)) (= (cdr (assoc 0 (entget cir))) "ARC")) cir (entlast)))
52.     (if (mirror3d (ssadd arc1) "XY" o "N")
53.       (setq arc2 (entlast))
54.     )
55.     (if command-s
56.       (command-s "_.ZOOM" "_P")
57.       (vl-cmdf "_.ZOOM" "_P")
58.     )
59.     (if command-s
60.       (command-s "_.UCS" "_P")
61.       (vl-cmdf "_.UCS" "_P")
62.     )
63.     (if arc1
64.       (setq arcs (cons arc1 arcs))
65.     )
66.     (if arc2
67.       (setq arcs (cons arc2 arcs))
68.     )
69.   )
70.  
71.   (defun process2 ( arc p / par arc1 arc2 ax1 ax2 ) ; arcss - lexical global
72.     (setq par (vlax-curve-getparamatpoint arc (vlax-curve-getclosestpointto arc p)))
73.     (setq arc1 (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object arc))))
74.     (setq ax1 (entget arc1))
75.     (entupd
76.       (cdr
77.         (assoc -1
78.           (entmod
79.             (subst (cons 51 par) (assoc 51 ax1) ax1)
80.           )
81.         )
82.       )
83.     )
84.     (setq arc2 (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object arc))))
85.     (setq ax2 (entget arc2))
86.     (entupd
87.       (cdr
88.         (assoc -1
89.           (entmod
90.             (subst (cons 50 par) (assoc 50 ax2) ax2)
91.           )
92.         )
93.       )
94.     )
95.     (entdel arc)
96.     (setq arcss (cons arc1 arcss) arcss (cons arc2 arcss))
97.   )
98.  
99.   (setq cmd (getvar (quote cmdecho)))
100.   (setvar (quote cmdecho) 0)
101.   (setq osm (getvar (quote osmode)))
102.   (setvar (quote osmode) 0)
103.   (if (not (vl-some (function (lambda ( x ) (wcmatch x "geom3d.*"))) (arx)))
104.     (if (findfile "geom3d.crx")
105.       (arxload (findfile "geom3d.crx"))
106.       (if (findfile "geom3d.arx")
107.         (arxload (findfile "geom3d.arx"))
108.       )
109.     )
110.   )
111.   (if (= 8 (logand 8 (getvar (quote undoctl))))
112.     (if command-s
113.       (command-s "_.UNDO" "_E")
114.       (vl-cmdf "_.UNDO" "_E")
115.     )
116.   )
117.   (if command-s
118.     (command-s "_.UNDO" "_M")
119.     (vl-cmdf "_.UNDO" "_M")
120.   )
121.   (if (= 0 (getvar (quote worlducs)))
122.     (progn
123.       (if command-s
124.         (command-s "_.UCS" "_W")
125.         (vl-cmdf "_.UCS" "_W")
126.       )
127.       (setq ucsf t)
128.     )
129.   )
130.   (if (setq ss (ssget "_:L" (list (cons 0 "CIRCLE"))))
131.     (progn
132.       ;;; breakeage of random oriented equatorial circles to half circle arcs ;;;
133.       (repeat (setq i (sslength ss))
134.         (setq ci (ssname ss (setq i (1- i))))
135.         (if (and ci (not (vlax-erased-p ci)))
136.           (progn
137.             (setq cix (entget ci))
138.             (setq o (cdr (assoc 10 cix)))
139.             (setq r (cdr (assoc 40 cix)))
140.             (setq cc (ssname ss (setq i (1- i))))
141.             (if (and cc (not (vlax-erased-p cc)))
142.               (progn
143.                 (setq ccx (entget cc))
144.                 (setq vec (mapcar (function *) (v^v (cdr (assoc 210 cix)) (cdr (assoc 210 ccx))) (list r r r)))
145.                 (setq p1 (mapcar (function +) o vec))
146.                 (setq p2 (mapcar (function -) o vec))
147.                 (process1 ci o p1 p2)
148.                 (process1 cc o p1 p2)
149.               )
150.             )
151.           )
152.         )
153.       )
154.       ;;; half circle arcs breakage to smaller composing arcs at their intersections ;;;
155.       (while (not (vl-every (function (lambda ( x ) (vl-some (function (lambda ( y ) (eq x y))) arcsp))) arcs))
156.         (setq arcsp arcs)
157.         (setq aarcs arcs arcss nil)
158.         (foreach arc1 aarcs
159.           (setq aarcs (vl-remove arc1 aarcs))
160.           (foreach arc2 aarcs
161.             (if
162.               (and
163.                 arc1
164.                 (not (vlax-erased-p arc1))
165.                 arc2
166.                 (not (vlax-erased-p arc2))
167.               )
168.               (progn
169.                 (setq a1x (entget arc1))
170.                 (setq a2x (entget arc2))
171.                 (setq o (cdr (assoc 10 a1x)))
172.                 (setq r (cdr (assoc 40 a1x)))
173.                 (if (not (equal (cdr (assoc 210 a1x)) (cdr (assoc 210 a2x)) 1e-6))
174.                   (progn
175.                     (setq vec (mapcar (function *) (v^v (cdr (assoc 210 a1x)) (cdr (assoc 210 a2x))) (list r r r)))
176.                     (setq p1 (mapcar (function +) o vec))
177.                     (setq p2 (mapcar (function -) o vec))
178.                     (if
179.                       (and
180.                         arc1
181.                         (not (vlax-erased-p arc1))
182.                         (equal p1 (vlax-curve-getclosestpointto arc1 p1) 1e-3)
183.                         (not (equal p1 (vlax-curve-getstartpoint arc1) 1e-3))
184.                         (not (equal p1 (vlax-curve-getendpoint arc1) 1e-3))
185.                       )
186.                       (process2 arc1 p1)
187.                     )
188.                     (if
189.                       (and
190.                         arc2
191.                         (not (vlax-erased-p arc2))
192.                         (equal p1 (vlax-curve-getclosestpointto arc2 p1) 1e-3)
193.                         (not (equal p1 (vlax-curve-getstartpoint arc2) 1e-3))
194.                         (not (equal p1 (vlax-curve-getendpoint arc2) 1e-3))
195.                       )
196.                       (process2 arc2 p1)
197.                     )
198.                     (if
199.                       (and
200.                         arc1
201.                         (not (vlax-erased-p arc1))
202.                         (equal p2 (vlax-curve-getclosestpointto arc1 p2) 1e-3)
203.                         (not (equal p2 (vlax-curve-getstartpoint arc1) 1e-3))
204.                         (not (equal p2 (vlax-curve-getendpoint arc1) 1e-3))
205.                       )
206.                       (process2 arc1 p2)
207.                     )
208.                     (if
209.                       (and
210.                         arc2
211.                         (not (vlax-erased-p arc2))
212.                         (equal p2 (vlax-curve-getclosestpointto arc2 p2) 1e-3)
213.                         (not (equal p2 (vlax-curve-getstartpoint arc2) 1e-3))
214.                         (not (equal p2 (vlax-curve-getendpoint arc2) 1e-3))
215.                       )
216.                       (process2 arc2 p2)
217.                     )
218.                   )
219.                 )
220.               )
221.             )
222.           )
223.         )
224.         (setq arcs (vl-remove-if (function vlax-erased-p) (append arcs arcss)))
225.       )
226.     )
227.   )
228.   (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
229.   (*error* nil)
230. )
231.  

[ribarm]

And just for info, since I gained little experience working on tree_branching *.lsp routines...
Be careful in AutoCAD with (vlax-curve-getpointatdist) function... In my case distance was greater than overall length of curve and instead of throwing out nil as a result - output, in AutoCAD result was starting point of curve (in my case it was SPLINE, but that doesn't matter generally speaking)... BricsCAD was here fine and I hadn't have to work to overcome issue... All in all, as I had time, I've cobbled out working both codes in both environments... It's just that something not necessity happen to had to be written...

[ribarm]

I've figured out what was the issue...
Only thing missing was (unit) sub function... I thought that cross product between 2 unit vectors inevitable produces unit vector as a result, but I was wrong... I've checked this and this is correct version... But, since, I've already worked on "lengths_along_pipe_trees.lsp" and tested it and on 3D arcs, now all works as desired... Just remember that when you apply it to network and pick crossing starting point, there must be free endings for which network is to be overdrawn with lengths, i.e. there must be no crossings at some places and no meetings with ending entity...

Cheers,
M.R.

Code - Auto/Visual Lisp: [Select]

1. (defun c:sphere_rnd-equatorial-circles_2_arcs ( / *error* unit v^v process1 process2 osm ucsf ss i ci cix o r cc ccx vec p1 p2 arc1 arc2 arcs arcsp a1x a2x arcss aarcs )
2.  
3.   (vl-load-com)
4.  
5.   (defun *error* ( m )
6.     (if ucsf
7.       (if command-s
8.         (command-s "_.UCS" "_P")
9.         (vl-cmdf "_.UCS" "_P")
10.       )
11.     )
12.     (if (= 8 (logand 8 (getvar (quote undoctl))))
13.       (if command-s
14.         (command-s "_.UNDO" "_E")
15.         (vl-cmdf "_.UNDO" "_E")
16.       )
17.     )
18.     (if osm
19.       (setvar (quote osmode) osm)
20.     )
21.     (if cmd
22.       (setvar (quote cmdecho) cmd)
23.     )
24.     (if m
25.       (prompt m)
26.     )
27.     (princ)
28.   )
29.  
30.   (defun unit ( v / d )
31.     (if (not (equal (setq d (distance (list 0.0 0.0 0.0) v)) 0.0 1e-8))
32.       (mapcar (function (lambda ( x ) (/ x d))) v)
33.       (progn
34.         (prompt "\nReference vector strength near 0.0... Invalid input specification... Quitting...")
35.         (exit)
36.       )
37.     )
38.   )
39.  
40.   (defun v^v ( u v )
41.     (list
42.       (- (* (cadr u) (caddr v)) (* (caddr u) (cadr v)))
43.       (- (* (caddr u) (car v)) (* (car u) (caddr v)))
44.       (- (* (car u) (cadr v)) (* (cadr u) (car v)))
45.     )
46.   )
47.  
48.   (defun process1 ( cir o p1 p2 / arc1 arc2 ) ; arcs - lexical global
49.     (if command-s
50.       (command-s "_.UCS" "_3P" o p2 (mapcar (function +) o (cdr (assoc 210 (entget cir)))))
51.       (vl-cmdf "_.UCS" "_3P" o p2 (mapcar (function +) o (cdr (assoc 210 (entget cir)))))
52.     )
53.     (if command-s
54.       (command-s "_.VPOINT" (mapcar (function +) (trans o 1 0) (trans (list 1.0 0.0 0.0) 1 0 t)) (trans o 1 0))
55.       (vl-cmdf "_.VPOINT" (mapcar (function +) (trans o 1 0) (trans (list 1.0 0.0 0.0) 1 0 t)) (trans o 1 0))
56.     )
57.     (if command-s
58.       (command-s "_.BREAK" cir (trans p1 0 1) (trans p2 0 1))
59.       (vl-cmdf "_.BREAK" cir (trans p1 0 1) (trans p2 0 1))
60.     )
61.     (setq arc1 (if (and cir (not (vlax-erased-p cir)) (= (cdr (assoc 0 (entget cir))) "ARC")) cir (entlast)))
62.     (if (mirror3d (ssadd arc1) "XY" o "N")
63.       (setq arc2 (entlast))
64.     )
65.     (if command-s
66.       (command-s "_.ZOOM" "_P")
67.       (vl-cmdf "_.ZOOM" "_P")
68.     )
69.     (if command-s
70.       (command-s "_.UCS" "_P")
71.       (vl-cmdf "_.UCS" "_P")
72.     )
73.     (if arc1
74.       (setq arcs (cons arc1 arcs))
75.     )
76.     (if arc2
77.       (setq arcs (cons arc2 arcs))
78.     )
79.   )
80.  
81.   (defun process2 ( arc p / par arc1 arc2 ax1 ax2 ) ; arcss - lexical global
82.     (setq par (vlax-curve-getparamatpoint arc (vlax-curve-getclosestpointto arc p)))
83.     (setq arc1 (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object arc))))
84.     (setq ax1 (entget arc1))
85.     (entupd
86.       (cdr
87.         (assoc -1
88.           (entmod
89.             (subst (cons 51 par) (assoc 51 ax1) ax1)
90.           )
91.         )
92.       )
93.     )
94.     (setq arc2 (vlax-vla-object->ename (vla-copy (vlax-ename->vla-object arc))))
95.     (setq ax2 (entget arc2))
96.     (entupd
97.       (cdr
98.         (assoc -1
99.           (entmod
100.             (subst (cons 50 par) (assoc 50 ax2) ax2)
101.           )
102.         )
103.       )
104.     )
105.     (entdel arc)
106.     (setq arcss (cons arc1 arcss) arcss (cons arc2 arcss))
107.   )
108.  
109.   (setq cmd (getvar (quote cmdecho)))
110.   (setvar (quote cmdecho) 0)
111.   (setq osm (getvar (quote osmode)))
112.   (setvar (quote osmode) 0)
113.   (if (not (vl-some (function (lambda ( x ) (wcmatch x "geom3d.*"))) (arx)))
114.     (if (findfile "geom3d.crx")
115.       (arxload (findfile "geom3d.crx"))
116.       (if (findfile "geom3d.arx")
117.         (arxload (findfile "geom3d.arx"))
118.       )
119.     )
120.   )
121.   (if (= 8 (logand 8 (getvar (quote undoctl))))
122.     (if command-s
123.       (command-s "_.UNDO" "_E")
124.       (vl-cmdf "_.UNDO" "_E")
125.     )
126.   )
127.   (if command-s
128.     (command-s "_.UNDO" "_M")
129.     (vl-cmdf "_.UNDO" "_M")
130.   )
131.   (if (= 0 (getvar (quote worlducs)))
132.     (progn
133.       (if command-s
134.         (command-s "_.UCS" "_W")
135.         (vl-cmdf "_.UCS" "_W")
136.       )
137.       (setq ucsf t)
138.     )
139.   )
140.   (if (setq ss (ssget "_:L" (list (cons 0 "CIRCLE"))))
141.     (progn
142.       ;;; breakeage of random oriented equatorial circles to half circle arcs ;;;
143.       (repeat (setq i (sslength ss))
144.         (setq ci (ssname ss (setq i (1- i))))
145.         (if (and ci (not (vlax-erased-p ci)))
146.           (progn
147.             (setq cix (entget ci))
148.             (setq o (cdr (assoc 10 cix)))
149.             (setq r (cdr (assoc 40 cix)))
150.             (setq cc (ssname ss (setq i (1- i))))
151.             (if (and cc (not (vlax-erased-p cc)))
152.               (progn
153.                 (setq ccx (entget cc))
154.                 (setq vec (mapcar (function *) (unit (v^v (cdr (assoc 210 cix)) (cdr (assoc 210 ccx)))) (list r r r)))
155.                 (setq p1 (mapcar (function +) o vec))
156.                 (setq p2 (mapcar (function -) o vec))
157.                 (process1 ci o p1 p2)
158.                 (process1 cc o p1 p2)
159.               )
160.             )
161.           )
162.         )
163.       )
164.       ;;; half circle arcs breakage to smaller composing arcs at their intersections ;;;
165.       (while (not (vl-every (function (lambda ( x ) (vl-some (function (lambda ( y ) (eq x y))) arcsp))) arcs))
166.         (setq arcsp arcs)
167.         (setq aarcs arcs arcss nil)
168.         (foreach arc1 aarcs
169.           (setq aarcs (vl-remove arc1 aarcs))
170.           (foreach arc2 aarcs
171.             (if
172.               (and
173.                 arc1
174.                 (not (vlax-erased-p arc1))
175.                 arc2
176.                 (not (vlax-erased-p arc2))
177.               )
178.               (progn
179.                 (setq a1x (entget arc1))
180.                 (setq a2x (entget arc2))
181.                 (setq o (cdr (assoc 10 a1x)))
182.                 (setq r (cdr (assoc 40 a1x)))
183.                 (if (not (equal (cdr (assoc 210 a1x)) (cdr (assoc 210 a2x)) 1e-6))
184.                   (progn
185.                     (setq vec (mapcar (function *) (unit (v^v (cdr (assoc 210 a1x)) (cdr (assoc 210 a2x)))) (list r r r)))
186.                     (setq p1 (mapcar (function +) o vec))
187.                     (setq p2 (mapcar (function -) o vec))
188.                     (if
189.                       (and
190.                         arc1
191.                         (not (vlax-erased-p arc1))
192.                         (equal p1 (vlax-curve-getclosestpointto arc1 p1) 1e-3)
193.                         (not (equal p1 (vlax-curve-getstartpoint arc1) 1e-3))
194.                         (not (equal p1 (vlax-curve-getendpoint arc1) 1e-3))
195.                       )
196.                       (process2 arc1 p1)
197.                     )
198.                     (if
199.                       (and
200.                         arc2
201.                         (not (vlax-erased-p arc2))
202.                         (equal p1 (vlax-curve-getclosestpointto arc2 p1) 1e-3)
203.                         (not (equal p1 (vlax-curve-getstartpoint arc2) 1e-3))
204.                         (not (equal p1 (vlax-curve-getendpoint arc2) 1e-3))
205.                       )
206.                       (process2 arc2 p1)
207.                     )
208.                     (if
209.                       (and
210.                         arc1
211.                         (not (vlax-erased-p arc1))
212.                         (equal p2 (vlax-curve-getclosestpointto arc1 p2) 1e-3)
213.                         (not (equal p2 (vlax-curve-getstartpoint arc1) 1e-3))
214.                         (not (equal p2 (vlax-curve-getendpoint arc1) 1e-3))
215.                       )
216.                       (process2 arc1 p2)
217.                     )
218.                     (if
219.                       (and
220.                         arc2
221.                         (not (vlax-erased-p arc2))
222.                         (equal p2 (vlax-curve-getclosestpointto arc2 p2) 1e-3)
223.                         (not (equal p2 (vlax-curve-getstartpoint arc2) 1e-3))
224.                         (not (equal p2 (vlax-curve-getendpoint arc2) 1e-3))
225.                       )
226.                       (process2 arc2 p2)
227.                     )
228.                   )
229.                 )
230.               )
231.             )
232.           )
233.         )
234.         (setq arcs (vl-remove-if (function vlax-erased-p) (append arcs arcss)))
235.       )
236.     )
237.   )
238.   (prompt "\nFor UNDO - type \"UNDO\" - \"Back\" option...")
239.   (*error* nil)
240. )
241.