Author Topic: --={ Challenge }=-- find general solution for collecting multiple loops...  (Read 913 times)

0 Members and 1 Guest are viewing this topic.

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
This my last post is attempt to solve, but those (foreach combos, just I can't manage to visualize better approach...

Link : https://www.cadtutor.net/forum/topic/77081-lisp-routine-to-specify-loops-in-a-network/?do=findComment&comment=615301

Thanks for attention, M.R.
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

d2010

  • Bull Frog
  • Posts: 323
The recusive self function , example Consforeach is worst think, because
  you slow -down too much the speed of AutoCad(every time autocad must donloading
Why?
Do you known ? How to replace the recursive function with non-rec?
How to increase the speed of stack?
Thanks
God Bless


Code: [Select]
(defun consforeach ( n )
    (if (> n 0)
      (progn
        '(foreach (read (strcat "e" (itoa n))) ell
        (consforeach (1- n))
      )
    )
  )

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
I've constructed some wrapper over external file (strcat (getvar 'tempprefix) "foo.lsp"), but it won't work... Can you check instead of me, maybe I don't see something obvious, cos' result is wrong...

Code - Auto/Visual Lisp: [Select]
  1. (defun c:loops ( / *error* consbyblk proc process consforeach closeparen conselst body cmd osm clay pea el ell s ss sss nolstt n nn elst fn )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if (and bound (not (vlax-erased-p bound)))
  6.       (entdel bound)
  7.     )
  8.     (if (= 8 (logand 8 (getvar (quote undoctl))))
  9.       (if command-s
  10.         (command-s "_.UNDO" "_E")
  11.         (vl-cmdf "_.UNDO" "_E")
  12.       )
  13.     )
  14.     (if cmd
  15.       (setvar (quote cmdecho) cmd)
  16.     )
  17.     (if osm
  18.       (setvar (quote osmode) osm)
  19.     )
  20.     (if clay
  21.       (setvar (quote clayer) clay)
  22.     )
  23.     (if pea
  24.       (setvar (quote peditaccept) pea)
  25.     )
  26.     (if m
  27.       (prompt m)
  28.     )
  29.     (princ)
  30.   )
  31.  
  32.   (defun consbyblk ( blk / no )
  33.     (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
  34.       (if (numberp (setq no (atoi (vla-get-textstring att))))
  35.         (setq nolst (cons no nolst))
  36.       )
  37.     )
  38.   )
  39.  
  40.   (defun proc ( p / nolst bound pl ss blk )
  41.     (setq bound (car (nentselp p)))
  42.     (sssetfirst nil (ssadd bound))
  43.     (getstring "\nENTER TO CONTINUE...")
  44.     (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
  45.     (entdel bound)
  46.     (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  47.       (progn
  48.         (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
  49.         (while (< 0 (getvar (quote cmdactive)))
  50.           (vl-cmdf "")
  51.         )
  52.       )
  53.     )
  54.     (foreach p pl
  55.       (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
  56.         (progn
  57.           (setq blk (ssname ss 0))
  58.           (consbyblk blk)
  59.         )
  60.       )
  61.     )
  62.     (setq nolstt (cons nolst nolstt))
  63.   )
  64.  
  65.   (defun process ( ss p )
  66.     (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
  67.       (proc p)
  68.       (progn
  69.         (vl-cmdf "_.JOIN" ss)
  70.         (while (< 0 (getvar (quote cmdactive)))
  71.           (vl-cmdf "")
  72.         )
  73.         (proc p)
  74.       )
  75.     )
  76.   )
  77.  
  78.   (defun consforeach ( n fn )
  79.     (if (> n 0)
  80.       (progn
  81.         (write-line (strcat "(foreach e" (itoa n) " ell") fn)
  82.         (if (> n 1)
  83.           (write-line (strcat "(setq ell (vl-remove e" (itoa n) " ell))") fn)
  84.         )
  85.         (consforeach (1- n) fn)
  86.       )
  87.     )
  88.   )
  89.  
  90.   (defun closeparen ( n fn )
  91.     (if (> n 0)
  92.       (progn
  93.         (write-line ")" fn)
  94.         (closeparen (1- n) fn)
  95.       )
  96.     )
  97.   )
  98.  
  99.   (defun conselst ( n fn )
  100.     (if (> n 0)
  101.       (progn
  102.         (write-line (strcat "(setq elst (cons e" (itoa n) " elst))") fn)
  103.         (conselst (1- n) fn)
  104.       )
  105.     )
  106.   )
  107.  
  108.   (defun body ( n fn )
  109.     (write-line "(vl-cmdf \"_.UNDO\" \"_G\")" fn)
  110.       (conselst n fn)
  111.       (write-line "(vl-catch-all-apply (function vl-cmdf) (cons \"_.UNION\" elst))" fn)
  112.       (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
  113.         (write-line "(vl-cmdf \"\")" fn)
  114.       (write-line ")" fn)
  115.       (write-line "(setq el (entlast) s (ssadd))" fn)
  116.       (write-line "(setq e (vl-some (function (lambda ( x ) (if (not (vlax-erased-p x)) x))) elst))" fn)
  117.       (write-line "(cond" fn)
  118.         (write-line "( e" fn)
  119.           (write-line "(vl-cmdf \"_.EXPLODE\" e)" fn)
  120.           (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
  121.             (write-line "(vl-cmdf \"\")" fn)
  122.           (write-line ")" fn)
  123.         (write-line ")" fn)
  124.         (write-line "( t" fn)
  125.           (write-line "(vl-cmdf \"_.EXPLODE\" \"_L\")" fn)
  126.           (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
  127.             (write-line "(vl-cmdf \"\")" fn)
  128.           (write-line ")" fn)
  129.         (write-line ")" fn)
  130.       (write-line ")" fn)
  131.       (write-line "(while (setq el (entnext el))" fn)
  132.       (write-line "(ssadd el s)" fn)
  133.       (write-line ")" fn)
  134.       (write-line "(setq elst nil)" fn)
  135.       (write-line "(if (wcmatch (cdr (assoc 0 (entget (ssname s 0)))) \"LINE,ARC\")" fn)
  136.         (write-line "(process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) \"_nea\"))" fn)
  137.     (write-line ")" fn)
  138.     (write-line "(vl-cmdf \"_.UNDO\" \"_B\")" fn)
  139.   )
  140.  
  141.   (setq cmd (getvar (quote cmdecho)))
  142.   (setvar (quote cmdecho) 0)
  143.   (setq osm (getvar (quote osmode)))
  144.   (setvar (quote osmode) 0)
  145.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
  146.     (progn
  147.       (vl-cmdf "_.LAYER" "_Thaw" "0")
  148.       (while (< 0 (getvar (quote cmdactive)))
  149.         (vl-cmdf "")
  150.       )
  151.     )
  152.   )
  153.   (setq clay (getvar (quote clayer)))
  154.   (setvar (quote clayer) "0")
  155.   (setq pea (getvar (quote peditaccept)))
  156.   (setvar (quote peditaccept) 1)
  157.   (if (= 8 (logand 8 (getvar (quote undoctl))))
  158.     (vl-cmdf "_.UNDO" "_E")
  159.   )
  160.   (vl-cmdf "_.UNDO" "_M")
  161.   (vl-cmdf "_.-OVERKILL" "_ALL")
  162.   (while (< 0 (getvar (quote cmdactive)))
  163.     (vl-cmdf "")
  164.   )
  165.   (vl-cmdf "_.ZOOM" "_Extents")
  166.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  167.   (setq el (entlast))
  168.   (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  169.   (setq sss (ssadd))
  170.   (while (setq el (entnext el))
  171.     (ssadd el sss)
  172.   )
  173.   (if (= 0 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  174.     (progn
  175.       (vl-cmdf "_.LAYER" "_Lock" "0water nodes")
  176.       (while (< 0 (getvar (quote cmdactive)))
  177.         (vl-cmdf "")
  178.       )
  179.     )
  180.   )
  181.   (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  182.     (progn
  183.       (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
  184.       (while (< 0 (getvar (quote cmdactive)))
  185.         (vl-cmdf "")
  186.       )
  187.     )
  188.   )
  189.   (vl-cmdf "_.REGION" sss "")
  190.   (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
  191.   (vl-cmdf "_.UNDO" "_G")
  192.   (foreach el ell
  193.     (vl-cmdf "_.EXPLODE" el)
  194.     (while (< 0 (getvar (quote cmdactive)))
  195.       (vl-cmdf "")
  196.     )
  197.     (setq s (ssget "_P"))
  198.     (process s (osnap (vlax-curve-getpointatparam (ssname s 0) (/ (+ (vlax-curve-getstartparam (ssname s 0)) (vlax-curve-getendparam (ssname s 0))) 2.0)) "_nea"))
  199.   )
  200.   (vl-cmdf "_.UNDO" "_B")
  201.   (setq ell (vl-remove (setq el (car (vl-sort ell (function (lambda ( a b ) (> (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))) ell))
  202.   (entdel el)
  203.   (setq nn (length ell))
  204.   (while (> nn 2)
  205.     (setq nn (1- nn))
  206.     (setq fn (open (strcat (getvar (quote tempprefix)) "foo.lsp") "w"))
  207.     (write-line "(defun foo nil" fn)
  208.     (consforeach nn fn)
  209.     (body nn fn)
  210.     (closeparen nn fn)
  211.     (write-line ")" fn)
  212.     (close fn)
  213.     (while (not (findfile (strcat (getvar (quote tempprefix)) "foo.lsp"))))
  214.     (load (strcat (getvar (quote tempprefix)) "foo.lsp"))
  215.     (foo)
  216.   )
  217.   (if (findfile (strcat (getvar (quote tempprefix)) "foo.lsp"))
  218.     (vl-file-delete (strcat (getvar (quote tempprefix)) "foo.lsp"))
  219.   )
  220.   (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
  221.     (progn
  222.       (vl-cmdf "_.ERASE" sss)
  223.       (while (< 0 (getvar (quote cmdactive)))
  224.         (vl-cmdf "")
  225.       )
  226.     )
  227.   )
  228.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  229.     (progn
  230.       (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
  231.       (while (< 0 (getvar (quote cmdactive)))
  232.         (vl-cmdf "")
  233.       )
  234.     )
  235.   )
  236.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  237.     (progn
  238.       (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
  239.       (while (< 0 (getvar (quote cmdactive)))
  240.         (vl-cmdf "")
  241.       )
  242.     )
  243.   )
  244.   (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
  245.   (vl-cmdf "_.ERASE" ss)
  246.   (while (< 0 (getvar (quote cmdactive)))
  247.     (vl-cmdf "")
  248.   )
  249.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  250.   (vl-cmdf "_.DRAWORDER" ss "" "_Back")
  251.   (if (and nolstt (listp nolstt) (listp (car nolstt)))
  252.     (setq nolstt (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b))))))
  253.   )
  254.   (princ nolstt)
  255.   (*error* nil)
  256. )
  257.  
« Last Edit: March 20, 2023, 01:09:56 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
I've finished... My last updated code is fully operational and working well...

Thanks for attention and taking part in this challenge...
« Last Edit: March 19, 2023, 11:31:47 AM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
I jumped up too early... Challenge is still open... It don't give expected results on just a little wider network...
So...
Happy coding...
See ya when someone finishes...
 8-)
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
It seems that it would be me that finishes...
And please download *.DWG from this link to see it working : https://www.theswamp.org/index.php?topic=58155.msg613632#msg613632

Recursive version :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:loops ( / *error* unique consbyblk proc process consforeach closeparen conselst body cmd osm clay pea el ell s ss sss nolstt n nn elst fn )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if (and bound (not (vlax-erased-p bound)))
  6.       (entdel bound)
  7.     )
  8.     (if (= 8 (logand 8 (getvar (quote undoctl))))
  9.       (if command-s
  10.         (command-s "_.UNDO" "_E")
  11.         (vl-cmdf "_.UNDO" "_E")
  12.       )
  13.     )
  14.     (if cmd
  15.       (setvar (quote cmdecho) cmd)
  16.     )
  17.     (if osm
  18.       (setvar (quote osmode) osm)
  19.     )
  20.     (if clay
  21.       (setvar (quote clayer) clay)
  22.     )
  23.     (if pea
  24.       (setvar (quote peditaccept) pea)
  25.     )
  26.     (if m
  27.       (prompt m)
  28.     )
  29.     (princ)
  30.   )
  31.  
  32.   (defun unique ( lst )
  33.     (if lst
  34.       (cons
  35.         (car lst)
  36.         (unique
  37.           (vl-remove-if
  38.             (function (lambda ( x )
  39.               (and
  40.                 (= (length (car lst)) (length x))
  41.                 (vl-every
  42.                   (function (lambda ( y )
  43.                     (vl-position y (car lst))
  44.                   ))
  45.                   x
  46.                 )
  47.               )
  48.             ))
  49.             (cdr lst)
  50.           )
  51.         )
  52.       )
  53.     )
  54.   )
  55.  
  56.   (defun consbyblk ( blk / no )
  57.     (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
  58.       (if (numberp (setq no (atoi (vla-get-textstring att))))
  59.         (setq nolst (cons no nolst))
  60.       )
  61.     )
  62.   )
  63.  
  64.   (defun proc ( p / nolst bound pl ss blk )
  65.     (setq bound (car (nentselp p)))
  66.     (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
  67.     (entdel bound)
  68.     (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  69.       (progn
  70.         (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
  71.         (while (< 0 (getvar (quote cmdactive)))
  72.           (vl-cmdf "")
  73.         )
  74.       )
  75.     )
  76.     (foreach p pl
  77.       (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
  78.         (progn
  79.           (setq blk (ssname ss 0))
  80.           (consbyblk blk)
  81.         )
  82.       )
  83.     )
  84.     (setq nolstt (cons nolst nolstt))
  85.   )
  86.  
  87.   (defun process ( ss p )
  88.     (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
  89.       (proc p)
  90.       (progn
  91.         (vl-cmdf "_.JOIN" ss)
  92.         (while (< 0 (getvar (quote cmdactive)))
  93.           (vl-cmdf "")
  94.         )
  95.         (proc p)
  96.       )
  97.     )
  98.   )
  99.  
  100.   (defun consforeach ( n fn )
  101.     (if (> n 0)
  102.       (progn
  103.         (write-line (strcat "(foreach e" (itoa n) " ell") fn)
  104.         (if (> n 1)
  105.           (write-line (strcat "(setq ell (vl-remove e" (itoa n) " ell))") fn)
  106.         )
  107.         (consforeach (1- n) fn)
  108.       )
  109.     )
  110.   )
  111.  
  112.   (defun closeparen ( n fn )
  113.     (if (> n 0)
  114.       (progn
  115.         (write-line ")" fn)
  116.         (closeparen (1- n) fn)
  117.       )
  118.     )
  119.   )
  120.  
  121.   (defun conselst ( n fn )
  122.     (if (> n 0)
  123.       (progn
  124.         (write-line (strcat "(setq elst (cons e" (itoa n) " elst))") fn)
  125.         (conselst (1- n) fn)
  126.       )
  127.     )
  128.   )
  129.  
  130.   (defun body ( n fn )
  131.     (write-line "(vl-cmdf \"UNDO\" \"_G\")" fn)
  132.     (conselst n fn)
  133.     (write-line "(vl-catch-all-apply (function vl-cmdf) (cons \"_.UNION\" elst))" fn)
  134.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
  135.     (write-line "(vl-cmdf \"\")" fn)
  136.     (write-line ")" fn)
  137.     (write-line "(setq el (entlast) s (ssadd))" fn)
  138.     (write-line "(setq e (vl-some (function (lambda ( x ) (if (not (vlax-erased-p x)) x))) elst))" fn)
  139.     (write-line "(cond" fn)
  140.     (write-line "( e" fn)
  141.     (write-line "(vl-cmdf \"_.EXPLODE\" e)" fn)
  142.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
  143.     (write-line "(vl-cmdf \"\")" fn)
  144.     (write-line ")" fn)
  145.     (write-line ")" fn)
  146.     (write-line "( t" fn)
  147.     (write-line "(vl-cmdf \"_.EXPLODE\" \"_L\")" fn)
  148.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
  149.     (write-line "(vl-cmdf \"\")" fn)
  150.     (write-line ")" fn)
  151.     (write-line ")" fn)
  152.     (write-line ")" fn)
  153.     (write-line "(while (setq el (entnext el))" fn)
  154.     (write-line "(ssadd el s)" fn)
  155.     (write-line ")" fn)
  156.     (write-line "(setq elst nil)" fn)
  157.     (write-line "(if (wcmatch (cdr (assoc 0 (entget (ssname s 0)))) \"LINE,ARC\")" fn)
  158.     (write-line "(process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) \"_nea\"))" fn)
  159.     (write-line ")" fn)
  160.     (write-line "(vl-cmdf \"UNDO\" \"_B\")" fn)
  161.   )
  162.  
  163.   (setq cmd (getvar (quote cmdecho)))
  164.   (setvar (quote cmdecho) 0)
  165.   (setq osm (getvar (quote osmode)))
  166.   (setvar (quote osmode) 0)
  167.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
  168.     (progn
  169.       (vl-cmdf "_.LAYER" "_Thaw" "0")
  170.       (while (< 0 (getvar (quote cmdactive)))
  171.         (vl-cmdf "")
  172.       )
  173.     )
  174.   )
  175.   (setq clay (getvar (quote clayer)))
  176.   (setvar (quote clayer) "0")
  177.   (setq pea (getvar (quote peditaccept)))
  178.   (setvar (quote peditaccept) 1)
  179.   (if (= 8 (logand 8 (getvar (quote undoctl))))
  180.     (vl-cmdf "_.UNDO" "_E")
  181.   )
  182.   (vl-cmdf "_.UNDO" "_M")
  183.   (vl-cmdf "_.-OVERKILL" "_ALL")
  184.   (while (< 0 (getvar (quote cmdactive)))
  185.     (vl-cmdf "")
  186.   )
  187.   (vl-cmdf "_.ZOOM" "_Extents")
  188.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water")))))
  189.     (progn
  190.       (vl-cmdf "_.LAYER" "_Thaw" "0water")
  191.       (while (< 0 (getvar (quote cmdactive)))
  192.         (vl-cmdf "")
  193.       )
  194.     )
  195.   )
  196.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water")))))
  197.     (progn
  198.       (vl-cmdf "_.LAYER" "_Unlock" "0water")
  199.       (while (< 0 (getvar (quote cmdactive)))
  200.         (vl-cmdf "")
  201.       )
  202.     )
  203.   )
  204.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  205.   (setq el (entlast))
  206.   (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  207.   (setq sss (ssadd))
  208.   (while (setq el (entnext el))
  209.     (ssadd el sss)
  210.   )
  211.   (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  212.     (progn
  213.       (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
  214.       (while (< 0 (getvar (quote cmdactive)))
  215.         (vl-cmdf "")
  216.       )
  217.     )
  218.   )
  219.   (vl-cmdf "_.REGION" sss "")
  220.   (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
  221.   (setq nn (1- (length ell)))
  222.   (foreach el ell
  223.     (vl-cmdf "_.EXPLODE" el)
  224.     (while (< 0 (getvar (quote cmdactive)))
  225.       (vl-cmdf "")
  226.     )
  227.     (setq s (ssget "_P"))
  228.     (process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) "_nea"))
  229.   )
  230.   (while (> nn 2)
  231.     (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  232.     (setq el (entlast))
  233.     (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  234.     (setq sss (ssadd))
  235.     (while (setq el (entnext el))
  236.       (ssadd el sss)
  237.     )
  238.     (vl-cmdf "_.REGION" sss "")
  239.     (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
  240.     (setq ell (vl-remove (setq el (car (vl-sort ell (function (lambda ( a b ) (> (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))) ell))
  241.     (entdel el)
  242.     (setq nn (1- nn))
  243.     (setq fn (open (strcat (getvar (quote tempprefix)) "foo.lsp") "w"))
  244.     (write-line "(defun foo nil" fn)
  245.     (consforeach nn fn)
  246.     (body nn fn)
  247.     (closeparen nn fn)
  248.     (write-line ")" fn)
  249.     (close fn)
  250.     (load (strcat (getvar (quote tempprefix)) "foo.lsp"))
  251.     (foo)
  252.     (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
  253.       (progn
  254.         (vl-cmdf "_.ERASE" sss)
  255.         (while (< 0 (getvar (quote cmdactive)))
  256.           (vl-cmdf "")
  257.         )
  258.       )
  259.     )
  260.   )
  261.   (if (findfile (strcat (getvar (quote tempprefix)) "foo.lsp"))
  262.     (vl-file-delete (strcat (getvar (quote tempprefix)) "foo.lsp"))
  263.   )
  264.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  265.     (progn
  266.       (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
  267.       (while (< 0 (getvar (quote cmdactive)))
  268.         (vl-cmdf "")
  269.       )
  270.     )
  271.   )
  272.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  273.     (progn
  274.       (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
  275.       (while (< 0 (getvar (quote cmdactive)))
  276.         (vl-cmdf "")
  277.       )
  278.     )
  279.   )
  280.   (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
  281.   (vl-cmdf "_.ERASE" ss)
  282.   (while (< 0 (getvar (quote cmdactive)))
  283.     (vl-cmdf "")
  284.   )
  285.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  286.   (vl-cmdf "_.DRAWORDER" ss "" "_Back")
  287.   (if (and nolstt (listp nolstt) (listp (car nolstt)))
  288.     (setq nolstt (unique (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b)))))))
  289.   )
  290.   (princ nolstt)
  291.   (*error* nil)
  292. )
  293.  

Iterative version :

Code - Auto/Visual Lisp: [Select]
  1. (defun c:loops ( / *error* unique consbyblk proc process consforeach closeparen conselst body cmd osm clay pea el ell s ss sss nolstt n nn elst fn )
  2.  
  3.  
  4.   (defun *error* ( m )
  5.     (if (and bound (not (vlax-erased-p bound)))
  6.       (entdel bound)
  7.     )
  8.     (if (= 8 (logand 8 (getvar (quote undoctl))))
  9.       (if command-s
  10.         (command-s "_.UNDO" "_E")
  11.         (vl-cmdf "_.UNDO" "_E")
  12.       )
  13.     )
  14.     (if cmd
  15.       (setvar (quote cmdecho) cmd)
  16.     )
  17.     (if osm
  18.       (setvar (quote osmode) osm)
  19.     )
  20.     (if clay
  21.       (setvar (quote clayer) clay)
  22.     )
  23.     (if pea
  24.       (setvar (quote peditaccept) pea)
  25.     )
  26.     (if m
  27.       (prompt m)
  28.     )
  29.     (princ)
  30.   )
  31.  
  32.   (defun unique ( lst / a ll )
  33.     (while (setq a (car lst))
  34.       (if (vl-some (function (lambda ( x ) (and (= (length x) (length a)) (vl-every (function (lambda ( y ) (vl-position y a))) x)))) (cdr lst))
  35.         (setq ll (cons a ll) lst (vl-remove-if (function (lambda ( x ) (and (= (length x) (length a)) (vl-every (function (lambda ( y ) (vl-position y a))) x)))) (cdr lst)))
  36.         (setq ll (cons a ll) lst (cdr lst))
  37.       )
  38.     )
  39.     (reverse ll)
  40.   )
  41.  
  42.   (defun consbyblk ( blk / no )
  43.     (foreach att (vlax-invoke (vlax-ename->vla-object blk) (quote getattributes))
  44.       (if (numberp (setq no (atoi (vla-get-textstring att))))
  45.         (setq nolst (cons no nolst))
  46.       )
  47.     )
  48.   )
  49.  
  50.   (defun proc ( p / nolst bound pl ss blk )
  51.     (setq bound (car (nentselp p)))
  52.     (setq pl (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) (entget bound))))
  53.     (entdel bound)
  54.     (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  55.       (progn
  56.         (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
  57.         (while (< 0 (getvar (quote cmdactive)))
  58.           (vl-cmdf "")
  59.         )
  60.       )
  61.     )
  62.     (foreach p pl
  63.       (if (setq ss (ssget "_CP" (list (mapcar (function +) (list -0.1 -0.1) p) (mapcar (function +) (list 0.1 -0.1) p) (mapcar (function +) (list 0.1 0.1) p) (mapcar (function +) (list -0.1 0.1) p)) (list (cons 0 "INSERT"))))
  64.         (progn
  65.           (setq blk (ssname ss 0))
  66.           (consbyblk blk)
  67.         )
  68.       )
  69.     )
  70.     (setq nolstt (cons nolst nolstt))
  71.   )
  72.  
  73.   (defun process ( ss p )
  74.     (if (not (vl-catch-all-error-p (vl-catch-all-apply (function vl-cmdf) (list "_.PEDIT" "_M" ss "" "_J" "" ""))))
  75.       (proc p)
  76.       (progn
  77.         (vl-cmdf "_.JOIN" ss)
  78.         (while (< 0 (getvar (quote cmdactive)))
  79.           (vl-cmdf "")
  80.         )
  81.         (proc p)
  82.       )
  83.     )
  84.   )
  85.  
  86.   (defun consforeach ( n fn )
  87.     (while (> n 0)
  88.       (progn
  89.         (write-line (strcat "(foreach e" (itoa n) " ell") fn)
  90.         (if (> n 1)
  91.           (write-line (strcat "(setq ell (vl-remove e" (itoa n) " ell))") fn)
  92.         )
  93.       )
  94.       (setq n (1- n))
  95.     )
  96.   )
  97.  
  98.   (defun closeparen ( n fn )
  99.     (while (> n 0)
  100.       (write-line ")" fn)
  101.       (setq n (1- n))
  102.     )
  103.   )
  104.  
  105.   (defun conselst ( n fn )
  106.     (while (> n 0)
  107.       (write-line (strcat "(setq elst (cons e" (itoa n) " elst))") fn)
  108.       (setq n (1- n))
  109.     )
  110.   )
  111.  
  112.   (defun body ( n fn )
  113.     (write-line "(vl-cmdf \"UNDO\" \"_G\")" fn)
  114.     (conselst n fn)
  115.     (write-line "(vl-catch-all-apply (function vl-cmdf) (cons \"_.UNION\" elst))" fn)
  116.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
  117.     (write-line "(vl-cmdf \"\")" fn)
  118.     (write-line ")" fn)
  119.     (write-line "(setq el (entlast) s (ssadd))" fn)
  120.     (write-line "(setq e (vl-some (function (lambda ( x ) (if (not (vlax-erased-p x)) x))) elst))" fn)
  121.     (write-line "(cond" fn)
  122.     (write-line "( e" fn)
  123.     (write-line "(vl-cmdf \"_.EXPLODE\" e)" fn)
  124.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
  125.     (write-line "(vl-cmdf \"\")" fn)
  126.     (write-line ")" fn)
  127.     (write-line ")" fn)
  128.     (write-line "( t" fn)
  129.     (write-line "(vl-cmdf \"_.EXPLODE\" \"_L\")" fn)
  130.     (write-line "(while (< 0 (getvar (quote cmdactive)))" fn)
  131.     (write-line "(vl-cmdf \"\")" fn)
  132.     (write-line ")" fn)
  133.     (write-line ")" fn)
  134.     (write-line ")" fn)
  135.     (write-line "(while (setq el (entnext el))" fn)
  136.     (write-line "(ssadd el s)" fn)
  137.     (write-line ")" fn)
  138.     (write-line "(setq elst nil)" fn)
  139.     (write-line "(if (wcmatch (cdr (assoc 0 (entget (ssname s 0)))) \"LINE,ARC\")" fn)
  140.     (write-line "(process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) \"_nea\"))" fn)
  141.     (write-line ")" fn)
  142.     (write-line "(vl-cmdf \"UNDO\" \"_B\")" fn)
  143.   )
  144.  
  145.   (setq cmd (getvar (quote cmdecho)))
  146.   (setvar (quote cmdecho) 0)
  147.   (setq osm (getvar (quote osmode)))
  148.   (setvar (quote osmode) 0)
  149.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0")))))
  150.     (progn
  151.       (vl-cmdf "_.LAYER" "_Thaw" "0")
  152.       (while (< 0 (getvar (quote cmdactive)))
  153.         (vl-cmdf "")
  154.       )
  155.     )
  156.   )
  157.   (setq clay (getvar (quote clayer)))
  158.   (setvar (quote clayer) "0")
  159.   (setq pea (getvar (quote peditaccept)))
  160.   (setvar (quote peditaccept) 1)
  161.   (if (= 8 (logand 8 (getvar (quote undoctl))))
  162.     (vl-cmdf "_.UNDO" "_E")
  163.   )
  164.   (vl-cmdf "_.UNDO" "_M")
  165.   (vl-cmdf "_.-OVERKILL" "_ALL")
  166.   (while (< 0 (getvar (quote cmdactive)))
  167.     (vl-cmdf "")
  168.   )
  169.   (vl-cmdf "_.ZOOM" "_Extents")
  170.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water")))))
  171.     (progn
  172.       (vl-cmdf "_.LAYER" "_Thaw" "0water")
  173.       (while (< 0 (getvar (quote cmdactive)))
  174.         (vl-cmdf "")
  175.       )
  176.     )
  177.   )
  178.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water")))))
  179.     (progn
  180.       (vl-cmdf "_.LAYER" "_Unlock" "0water")
  181.       (while (< 0 (getvar (quote cmdactive)))
  182.         (vl-cmdf "")
  183.       )
  184.     )
  185.   )
  186.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  187.   (setq el (entlast))
  188.   (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  189.   (setq sss (ssadd))
  190.   (while (setq el (entnext el))
  191.     (ssadd el sss)
  192.   )
  193.   (if (= 0 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  194.     (progn
  195.       (vl-cmdf "_.LAYER" "_Freeze" "0water nodes")
  196.       (while (< 0 (getvar (quote cmdactive)))
  197.         (vl-cmdf "")
  198.       )
  199.     )
  200.   )
  201.   (vl-cmdf "_.REGION" sss "")
  202.   (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
  203.   (setq nn (1- (length ell)))
  204.   (foreach el ell
  205.     (vl-cmdf "_.EXPLODE" el)
  206.     (while (< 0 (getvar (quote cmdactive)))
  207.       (vl-cmdf "")
  208.     )
  209.     (setq s (ssget "_P"))
  210.     (process s (osnap (vlax-curve-getpointatparam (ssname s 0) 0.01) "_nea"))
  211.   )
  212.   (while (> nn 2)
  213.     (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  214.     (setq el (entlast))
  215.     (vl-cmdf "_.COPY" ss "" "_non" (list 0.0 0.0 0.0) "_non" (list 0.0 0.0 0.0))
  216.     (setq sss (ssadd))
  217.     (while (setq el (entnext el))
  218.       (ssadd el sss)
  219.     )
  220.     (vl-cmdf "_.REGION" sss "")
  221.     (setq ell (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex (ssget "_A" (list (cons 0 "REGION") (cons 8 "0")))))))
  222.     (setq ell (vl-remove (setq el (car (vl-sort ell (function (lambda ( a b ) (> (vla-get-area (vlax-ename->vla-object a)) (vla-get-area (vlax-ename->vla-object b)))))))) ell))
  223.     (entdel el)
  224.     (setq nn (1- nn))
  225.     (setq fn (open (strcat (getvar (quote tempprefix)) "foo.lsp") "w"))
  226.     (write-line "(defun foo nil" fn)
  227.     (consforeach nn fn)
  228.     (body nn fn)
  229.     (closeparen nn fn)
  230.     (write-line ")" fn)
  231.     (close fn)
  232.     (load (strcat (getvar (quote tempprefix)) "foo.lsp"))
  233.     (foo)
  234.     (if (and sss (= (type sss) (quote pickset)) (< 0 (sslength sss)))
  235.       (progn
  236.         (vl-cmdf "_.ERASE" sss)
  237.         (while (< 0 (getvar (quote cmdactive)))
  238.           (vl-cmdf "")
  239.         )
  240.       )
  241.     )
  242.   )
  243.   (if (findfile (strcat (getvar (quote tempprefix)) "foo.lsp"))
  244.     (vl-file-delete (strcat (getvar (quote tempprefix)) "foo.lsp"))
  245.   )
  246.   (if (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  247.     (progn
  248.       (vl-cmdf "_.LAYER" "_Unlock" "0water nodes")
  249.       (while (< 0 (getvar (quote cmdactive)))
  250.         (vl-cmdf "")
  251.       )
  252.     )
  253.   )
  254.   (if (= 1 (logand 1 (cdr (assoc 70 (tblsearch "LAYER" "0water nodes")))))
  255.     (progn
  256.       (vl-cmdf "_.LAYER" "_Thaw" "0water nodes")
  257.       (while (< 0 (getvar (quote cmdactive)))
  258.         (vl-cmdf "")
  259.       )
  260.     )
  261.   )
  262.   (setq ss (ssget "_A" (list (cons 0 "REGION") (cons 8 "0"))))
  263.   (vl-cmdf "_.ERASE" ss)
  264.   (while (< 0 (getvar (quote cmdactive)))
  265.     (vl-cmdf "")
  266.   )
  267.   (setq ss (ssget "_A" (list (cons 0 "LWPOLYLINE") (cons 8 "0water"))))
  268.   (vl-cmdf "_.DRAWORDER" ss "" "_Back")
  269.   (if (and nolstt (listp nolstt) (listp (car nolstt)))
  270.     (setq nolstt (unique (vl-sort nolstt (function (lambda ( a b ) (< (length a) (length b)))))))
  271.   )
  272.   (princ nolstt)
  273.   (*error* nil)
  274. )
  275.  

HTH.
M.R.
« Last Edit: March 21, 2023, 01:51:21 PM by ribarm »
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube

ribarm

  • Gator
  • Posts: 3225
  • Marko Ribar, architect
I don't quite understand... I have situation where there is no matching between ACAD and BCAD...

Here are results...

Code: [Select]
;;; ACAD
(setq l1 '((11 4 3 12) (3 2 8 7) (12 3 2 1) (4 11 10 5) (5 6 7 3 4) (2 1 12 11 4 3) (3 12 1 2 8 7) (11 10 5 4 3 12) (11 4 5 6 7 3 12) (3 2 8 7 6 5 4) (11 10 5 6 7 3 4) (11 10 5 6 7 3 12) (2 1 12 11 10 5 4 3) (3 2 8 7 6 5 10 11 4) (11 10 5 6 7 8 2 3 12) (10 5 6 7 3 2 1 12 11) (10 5 6 7 8 2 1 12 11) (3 12 1 2 8 7 6 5 10 11 4)))

;;; BCAD
(setq l2 '((5 4 11 10) (12 3 2 1) (7 8 2 3) (11 4 3 12) (3 4 5 6 7) (12 3 7 8 2 1) (5 4 3 12 11 10) (12 11 4 3 2 1) (5 6 7 3 4 11 10) (5 6 7 8 2 3 4) (3 12 11 4 5 6 7) (5 6 7 3 12 11 10) (5 4 3 2 1 12 11 10) (12 11 4 3 7 8 2 1) (3 2 1 12 11 4 5 6 7) (6 7 8 2 3 12 11 4 5) (5 6 7 8 2 3 12 11 10) (12 11 4 5 6 7 8 2 1) (10 5 6 7 8 2 1 12 11) (5 4 3 7 8 2 1 12 11 10)))

(defun unique ( lst )
  (if lst
    (cons
      (car lst)
      (unique
        (vl-remove-if
          (function (lambda ( x )
            (and
              (= (length (car lst)) (length x))
              (vl-every
                (function (lambda ( y )
                  (vl-position y (car lst))
                ))
                x
              )
            )
          ))
          (cdr lst)
        )
      )
    )
  )
)

(setq ll (vl-sort (unique (append l1 l2)) (function (lambda ( a b ) (< (length a) (length b))))))

;;;
;|
((11 4 3 12) (3 2 8 7) (12 3 2 1) (4 11 10 5) (5 6 7 3 4) (2 1 12 11 4 3) (3 12 1 2 8 7) (11 10 5 4 3 12) (11 4 5 6 7 3 12) (3 2 8 7 6 5 4) (11 10 5 6 7 3 4) (11 10 5 6 7 3 12) (2 1 12 11 10 5 4 3) (12 11 4 3 7 8 2 1) (3 2 8 7 6 5 10 11 4) (11 10 5 6 7 8 2 3 12) (10 5 6 7 3 2 1 12 11) (10 5 6 7 8 2 1 12 11) (3 2 1 12 11 4 5 6 7) (6 7 8 2 3 12 11 4 5) (12 11 4 5 6 7 8 2 1) (5 4 3 7 8 2 1 12 11 10) (3 12 1 2 8 7 6 5 10 11 4))
|;

Well, I thought I did it, but you'll never know where rabbit lies...
 :wideeyed:
Marko Ribar, d.i.a. (graduated engineer of architecture)

:)

M.R. on Youtube