Author Topic: Fix routine for further develop/testing...  (Read 530 times)

0 Members and 1 Guest are viewing this topic.

ribarm

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

Thanks, M.R.
« Last Edit: October 04, 2022, 01:12:42 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

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

If someone is willing to step in, I'll be very grateful...
M.R.
« Last Edit: September 29, 2022, 07:37:34 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

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

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 2829
  • Marko Ribar, architect
Re: Fix routine for further develop/testing...
« Reply #3 on: October 02, 2022, 06:25:15 AM »
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...
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

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

:)

M.R. on Youtube