Selection sets

Автор Тема: Selection sets  (Прочитано 31377 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Re: Selection sets
« Ответ #15 : 30-01-2020, 21:42:26 »
Чистим почти после каждого обнуления наборов...
Вообще-то чистка - это и есть обнуление наборов. Еще раз. Нужно разбираться с программами, которые вы используете.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн altverАвтор темы

  • ADN OPEN
  • ***
  • Сообщений: 118
  • Карма: 2
Re: Selection sets
« Ответ #16 : 30-01-2020, 21:45:28 »
Чистим почти после каждого обюнуления наборов...и в какой то момент-бац...и все!  Интересно, что этот "бац" сразу посе обнуления...

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Re: Selection sets
« Ответ #17 : 30-01-2020, 21:48:14 »
Чистим почти после каждого обюнуления наборов...и в какой то момент-бац...и все!  Интересно, что этот "бац" сразу посе обнуления...
Я предупреждал, что этот алгоритм может не помочь. И более того другого алгоритма нет.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Re: Selection sets
« Ответ #18 : 31-01-2020, 10:08:40 »
Без исходных кодов используемых lisp решения может и не быть. Я подозреваю, что просто не очень качественно написаны программы.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн altverАвтор темы

  • ADN OPEN
  • ***
  • Сообщений: 118
  • Карма: 2
Re: Selection sets
« Ответ #19 : 31-01-2020, 13:45:54 »
Когда-то, очень давно на прсторах интернета нашел вот этот лисп. Импирическим путем понял, что он накапливает наборы. Хотя может я и не прав...


Код - Auto/Visual Lisp [Выбрать]
  1. ;;  
  2.  
  3. (defun My-overkill2 ( alst Tolerance / lst ss fuz ignore no-plines n-partial no-EndtoEnd
  4.                               ss2 n na plst na2 vlst j k
  5.                      )
  6.  
  7. ; (acet-autoload '("pljoin.lsp" "(acet-pljoin ss st fuz)"))
  8.  (C:clr_sel)
  9.  
  10.  ;; extract the arguments from the arg list
  11.  (setq lst '(ss fuz ignore no-plines no-partial no-EndtoEnd))
  12.  (setq n 0)
  13.  (repeat (min (length alst) (length lst))
  14.   (set (nth n lst) (nth n alst))
  15.  (setq n (+ n 1));setq
  16.  );repeat
  17.  (setq lst nil)
  18.  
  19.  
  20.  (acet-sysvar-set
  21.   '("highlight" 0
  22.       "ucsicon" 0
  23.     "pickstyle" 0
  24.        "osmode" 0
  25.    )
  26.  )
  27.  
  28.  (if (not no-plines)
  29.      (progn
  30.       ;; Break plines down to individual objects and re-assemble what's left over later
  31.       (setq plst (acet-plines-explode ss)
  32.               ss (car plst)                     ;; new selection set with plines removed and new objects added
  33.             plst (cadr plst)                    ;; data used to re-build the plines later
  34.       );setq
  35.      );progn then ok to optimize plines
  36.  );if
  37.  
  38.  ;; Delete the perfect matches first
  39.  (setq ss2 (acet-ss-remove-dups ss fuz ignore)
  40.         ss (car ss2)
  41.        ss2 (cadr ss2)
  42.  );setq
  43.  (if ss2
  44.      (progn
  45.       ;(command "_.erase" ss2 "")
  46.       (princ (acet-str-format "\n%1 duplicate(s) deleted.\n" (itoa (sslength ss2))))
  47.      );progn then
  48.      (setq ss2 (ssadd));setq else create an empty selection set
  49.  );if
  50.  
  51.  (if (not (and no-partial       ; don't do overlappers and don't do endtoend means exact
  52.                no-endtoend      ; dups only so we're done if both of these are true
  53.           )
  54.      );not
  55.      (progn
  56.       ;;;;;;;;;;(setq vlst (acet-overkill-ss->primitives2 ss 0.0000001 ignore)      **********************************************************
  57.                (setq vlst (my-overk-primitives2 ss tolerance ignore)
  58.                j 0
  59.       );setq then ok to combine at least some parallel segments
  60.      );progn then
  61.  );if
  62.  
  63.  (acet-ui-progress-init "Optimizing objects" (length vlst))
  64.  (setq n 1)
  65.  (foreach lst vlst
  66.    (if (> (length lst) 2)
  67.        (progn
  68.         (if (= 0 (car (car lst)))
  69.             (setq k (my-over2 lst ss2 fuz no-partial no-endtoend)); lines
  70.             (setq k (my-over-arcs2 lst ss2 fuz no-partial no-endtoend)); arcs
  71.         );if
  72.         (setq ss2 (cadr k)
  73.                 k (car k)
  74.                 j (+ j k)
  75.         );setq
  76.         (princ "                                                      ")
  77.         (princ "\r")
  78.         (princ (acet-str-format "%1 object(s) deleted." (itoa j)))
  79.        );progn then more than one object in the list
  80.    );if
  81.   (acet-ui-progress-safe n)
  82.   (setq n (+ n 1));setq
  83.  );foreach list of potential over-lapers
  84.  (acet-ui-progress-done)
  85.  
  86.  (setq na (entlast))
  87.  
  88.  (if (and ss2
  89.           (> (sslength ss2) 0)
  90.      );and
  91.      (acet-ss-entdel ss2) ;then delete this stuff before pline re-build
  92.  );if
  93.  
  94.  (if plst
  95.      (acet-plines-rebuild plst)
  96.  );if
  97.  
  98.  (if (and ss2
  99.           (> (sslength ss2) 0)
  100.      );and
  101.      (progn
  102.       (acet-ss-entdel ss2)                              ;; bring it back and then use erase
  103.       (acet-safe-command T T (list "_.erase" ss2 ""))   ;; so that can be oops'd back
  104.      );progn then
  105.      (acet-ss-clear-prev)
  106.  );if
  107.  
  108.  (acet-sysvar-restore)
  109.  (princ "\n")
  110.  ss2
  111. );defun my-overkill
  112.  
  113.  
  114. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  115.  
  116. ;;
  117. (defun my-over2 ( lst ss2 fuz no-partial no-endtoend /
  118.                                      index m m2 n x na na2 p1 p2 p3 p4 mod j a b e1
  119.                                    )
  120.  
  121.  (setq   a (car lst)
  122.        lst (cdr lst)
  123.          m (nth 1 a)    ;; xy slope
  124.         m2 (nth 3 a)    ;; yz slope
  125.  );setq
  126.  
  127.  ;; if the lines are not vertical then set index x else set it to y
  128.  (cond
  129.   (m (setq index 0))    ;; slope is defined in xy plane so use x coord
  130.   (m2 (setq index 1))   ;; slope is defined in yz plane so use y coord
  131.   (T (setq index 2))    ;; the lines is parallel to the z axis so use the z coord.
  132.  );cond close
  133.  
  134. ;(print a)
  135. ;(print lst)
  136. ;(print index)
  137. ;(getstring "hey")
  138.  
  139.  ;; Get the lines in a left to right configuration
  140.  ;; then sort the list of lines from left to right
  141.  ;;
  142.  (setq lst (mapcar '(lambda ( x / a b )
  143.                       (if (< (nth index (car x))
  144.                              (nth index (cadr x))
  145.                           )
  146.                           (setq a (car x)
  147.                                 b (cadr x)
  148.                           );setq then
  149.                           (setq b (car x)
  150.                                 a (cadr x)
  151.                           );setq else
  152.                       );if
  153.                       (list a b (caddr x))
  154.                     )
  155.                     lst
  156.            );mapcar
  157.        lst (vl-sort lst
  158.                     '(lambda (a b)
  159.                       (< (nth index (car a)) (nth index (car b)))
  160.                      )
  161.            );vl-sort
  162.          x (car lst)
  163.         p1 (car x)
  164.         p2 (cadr x)
  165.         na (caddr x)
  166.          j 0
  167.  );setq
  168.  
  169.  (setq n 1)
  170.  (repeat (- (length lst) 1)
  171.  (setq   x (nth n lst)
  172.         p3 (car x)
  173.         p4 (cadr x)
  174.        na2 (caddr x)
  175.  );setq
  176.  (cond
  177.   ((equal (nth index p3) (nth index p2) fuz)
  178.    (if (not no-endtoend)
  179.        (progn
  180.         (if (> (nth index p4) (nth index p2))
  181.             (setq  p2 p4
  182.                   mod T
  183.             );setq then partial overlap
  184.         );if
  185.         (setq ss2 (ssadd na2 ss2))
  186.         ;(entdel na2)
  187.         (setq j (+ j 1))
  188.        );progn then ok to combine endtoend
  189.    );if
  190.   );cond #1 end to end
  191.  
  192.   ((< (nth index p3) (nth index p2))
  193.    (if (not no-partial)
  194.        (progn
  195.         (if (> (nth index p4) (nth index p2))
  196.             (setq  p2 p4
  197.                   mod T
  198.             );setq then partial overlap
  199.         );if
  200.         (setq ss2 (ssadd na2 ss2))
  201.         ;(entdel na2)
  202.         (setq j (+ j 1))
  203.        );progn then ok to combine partially overlaping objects
  204.    );if
  205.   );cond #2 overlap-age
  206.   (T
  207.    (if mod
  208.        (progn
  209.         (setq e1 (entget na)
  210.               e1 (subst (cons 10 p1) (assoc 10 e1) e1)
  211.               e1 (subst (cons 11 p2) (assoc 11 e1) e1)
  212.         );setq
  213.         (entmod e1)
  214.        );progn then modify the first ent before moving on to the next non-overlaper
  215.    );if
  216.    (setq p1 p3
  217.          p2 p4
  218.          na na2
  219.    );setq
  220.    (setq mod nil)
  221.   );cond #3 no overlap
  222.  );cond close
  223.  (setq n (+ n 1))
  224.  );repeat
  225.  (if mod
  226.      (progn
  227.       (setq e1 (entget na)
  228.             e1 (subst (cons 10 p1) (assoc 10 e1) e1)
  229.             e1 (subst (cons 11 p2) (assoc 11 e1) e1)
  230.       );setq
  231.       (entmod e1)
  232.      );progn then modify
  233.  );if
  234.  
  235.  
  236.  ;; Return the number of objects deleted and the update selection set
  237.  (list j ss2)
  238. );defun my-overkill-resolve-lines
  239.  
  240.  
  241. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  242. ;
  243. ;;
  244. (defun my-over-arcs2 ( lst ss2 fuz no-partial no-endtoend /
  245.                                     index slope n x na na2 a b a2 b2 mod j e1
  246.                                   )
  247.  
  248.  (setq lst (cdr lst)
  249.        lst (mapcar '(lambda ( x / a b )
  250.                       (setq a (acet-angle-format (nth 2 x))
  251.                             b (acet-angle-format (nth 3 x))
  252.                       )
  253.                       (if (<= b a)
  254.                           (setq b (+ b pi pi))
  255.                       );if
  256.                       (list (nth 0 x) (nth 1 x) a b (nth 4 x))
  257.                     )
  258.                     lst
  259.            );mapcar
  260.        lst (vl-sort lst
  261.                     '(lambda (a b)
  262.                       (< (nth 2 a) (nth 2 b))
  263.                      )
  264.            );vl-sort
  265.          x (car lst)
  266.          a (nth 2 x) ;start angle
  267.          b (nth 3 x) ;end angle
  268.         na (nth 4 x)
  269.          j 0
  270.  );setq
  271.  (setq n 1)
  272.  (repeat (- (length lst) 1)
  273.  (setq   x (nth n lst)
  274.         a2 (nth 2 x)
  275.         b2 (nth 3 x)
  276.        na2 (nth 4 x)
  277.  );setq
  278.  
  279.  (cond
  280.   ((equal a2 b 0.00000001)
  281.    (if (not no-endtoend)
  282.        (progn
  283.         (if (> b2 b)
  284.              (setq   b b2
  285.                    mod T
  286.              );setq then
  287.         );if
  288.         (setq ss2 (ssadd na2 ss2))
  289.         ;(entdel na2)
  290.         (setq j (+ j 1))
  291.        );progn ok to combine end to end
  292.    );if
  293.   );cond #1 end to end
  294.  
  295.   ((< a2 b)
  296.    (if (not no-partial)
  297.        (progn
  298.         (if (> b2 b)
  299.             (setq   b b2
  300.                   mod T
  301.             );setq then
  302.         );if
  303.         (setq ss2 (ssadd na2 ss2))
  304.         ;(entdel na2)
  305.         (setq j (+ j 1))
  306.        );progn then ok to combine partial overlap
  307.    );if
  308.   );cond #2 overlap
  309.  
  310.   (T
  311.       (if mod
  312.           (progn
  313.            (setq e1 (entget na))
  314.            (if (acet-angle-equal a b 0.00000001)
  315.                (progn
  316.                 (setq e1 (subst '(0 . "CIRCLE") (assoc 0 e1) e1)
  317.                       e1 (vl-remove (assoc 50 e1) e1)
  318.                       e1 (vl-remove (assoc 51 e1) e1)
  319.                 );setq
  320.                 (while (assoc 100 e1)
  321.                   (setq e1 (vl-remove (assoc 100 e1) e1));setq
  322.                 );while
  323.                 (entmake e1)
  324.                 (entdel na)
  325.                 (setq na (entlast))
  326.                );progn then change it to a circle by entmaking a new circle and deleting the arc
  327.                (progn
  328.                 (setq e1 (subst (cons 50 a) (assoc 50 e1) e1)
  329.                       e1 (subst (cons 51 b) (assoc 51 e1) e1)
  330.                 );setq
  331.                 (entmod e1)
  332.                );progn else just entmod the arc
  333.            );if
  334.           );progn then modify the first ent before moving on to the next non-overlaper
  335.       );if
  336.       (setq  a a2
  337.              b b2
  338.             na na2
  339.       );setq
  340.       (setq mod nil)
  341.   );cond #3 no overlap
  342.  );cond close
  343.  (setq n (+ n 1))
  344.  );repeat
  345.  (if mod
  346.      (progn
  347.       (setq e1 (entget na))
  348.       (if ;;;(acet-angle-equal a b 0.00000001);;********************************************
  349.           (acet-angle-equal a b tolerance)
  350.           (progn
  351.            (setq e1 (subst '(0 . "CIRCLE") (assoc 0 e1) e1)
  352.                  e1 (vl-remove (assoc 50 e1) e1)
  353.                  e1 (vl-remove (assoc 51 e1) e1)
  354.            );setq
  355.            (while (assoc 100 e1)
  356.             (setq e1 (vl-remove (assoc 100 e1) e1));setq
  357.            );while
  358.            (entmake e1)
  359.            (entdel na)
  360.            (setq na (entlast))
  361.           );progn then change it to a circle by entmaking a new circle and deleting the arc
  362.           (progn
  363.            (setq e1 (subst (cons 50 a) (assoc 50 e1) e1)
  364.                  e1 (subst (cons 51 b) (assoc 51 e1) e1)
  365.            );setq
  366.            (entmod e1)
  367.           );progn else just entmod the arc
  368.       );if
  369.      );progn then modify the first ent before moving on to the next non-overlaper
  370.  );if
  371.  
  372.  ;; Return the number of objects deleted and the update selection set
  373.  (list j ss2)
  374. );defun my-overkill-resolve-arcs
  375.  
  376. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  377. (defun my-over-data2 ( e1 fuz genprops / p1 p2 dx dy dz m b m2 b2 xv th )
  378.  
  379.  (setq p1 (cdr (assoc 10 e1))
  380.        p2 (cdr (assoc 11 e1))
  381.        dx (- (car p2) (car p1))
  382.        dy (- (cadr p2) (cadr p1))
  383.        dz (- (caddr p2) (caddr p1))
  384.  );setq
  385.  ;; first get the slope and y intercept in the xy plane.
  386.  (if (and (/= dx 0.0)
  387.           (setq m (/ dy dx))            ;slope
  388.           (< (abs m) 1.0e+010)
  389.      );and
  390.      (progn
  391.       (setq b (- (cadr p1)      ;y-intercept -> b=y-m*x
  392.                  (* m (car p1))
  393.               )
  394.       );setq
  395.      );progn then
  396.      (setq m nil      ;undefined slope
  397.            b (car p1) ;x-intercept
  398.      );setq else
  399.  );if
  400.  ;; Now get the slope and z intercept in a different plane
  401.  (if (and m
  402.           ;;(equal m 0.0 0.00000001)
  403.           (equal m 0.0 tolerance)
  404.      );and
  405.      (progn
  406.       ;; then use the xz plane because the slope is undefined in the yz
  407.       (if (and (/= dx 0.0)
  408.                (setq m2 (/ dz dx))              ;slope
  409.                (< (abs m2) 1.0e+010)
  410.           );and
  411.           (setq b2 (- (caddr p1)        ;z-intercept -> b2=z-m2*x
  412.                       (* m2 (car p1))
  413.                    )
  414.           );setq then
  415.           (setq m2 nil       ;undefined slope
  416.                 b2 (car p1) ;z-intercept
  417.           );setq else
  418.       );if
  419.      );progn then use xz plane
  420.      (progn
  421.       ;; else use yz plane
  422.       (if (and (/= dy 0.0)
  423.                (setq m2 (/ dz dy))              ;slope
  424.                (< (abs m2) 1.0e+010)
  425.           );and
  426.           (setq b2 (- (caddr p1)        ;z-intercept -> b2=z-m2*y
  427.                       (* m2 (cadr p1))
  428.                    )
  429.           );setq then
  430.           (setq m2 nil       ;undefined slope
  431.                 b2 (cadr p1) ;z-intercept
  432.           );setq else
  433.       );if
  434.      );progn else use yz plane
  435.  );if
  436.  (if m
  437.      ;;(setq m (acet-calc-round m 0.00000001))  ;; xy plane slope
  438.        (setq m (acet-calc-round m tolerance))
  439.  );if
  440.  (if m2
  441.    ;;  (setq m2 (acet-calc-round m2 0.00000001))        ;; yz slope
  442.    (setq m2 (acet-calc-round m2 tolerance))
  443.  );if
  444.  (setq  b (acet-calc-round b fuz)                       ;; y intercept
  445.        b2 (acet-calc-round b2 fuz)                      ;; z intercept
  446.  );setq
  447.  (if (setq th (cdr (assoc 39 e1)))
  448.      (setq xv (cdr (assoc 210 e1))
  449.            ;;xv (mapcar '(lambda (x) (acet-calc-round x 0.00000001)) xv)
  450.            xv (mapcar '(lambda (x) (acet-calc-round x tolerance)) xv)
  451.      );setq then it has thickness so we need to bring the extrusion vector along for the ride
  452.  );if
  453.  (if xv
  454.      (list 0 m b m2 b2
  455.            xv
  456.            (my-over-get2 e1 genprops)   ;; general data
  457.      );list
  458.      (list 0 m b m2 b2
  459.            (my-over-get2 e1 genprops)   ;; general data
  460.      );list
  461.  );if
  462. );defun my-overkill-line-data
  463.  
  464. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  465. ;Takes an elist and a list of group codes and returns a list of dotted pairs for that entity.
  466. ;
  467. (defun my-over-get2 ( e1 genprops / a lst )
  468.  (foreach gcode genprops
  469.   (if (not (setq a (assoc gcode e1)))
  470.       (setq a (list gcode))
  471.   );if
  472.   (setq lst (cons a lst))
  473.  );foreach
  474.  lst
  475. );defun my-overkill-gen-prop-get
  476.  
  477. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  478. ;similar to ai_utils version except more precision is allowed for small floating point numbers
  479. (defun my-rtos2 (val / a b units old_dimzin)
  480.   (setq units (getvar "lunits"))
  481.   ;; No fiddling if units are Architectural or Fractional
  482.   (if (or (= units 4) (= units 5))
  483.     (rtos val)
  484.     ;; Otherwise work off trailing zeros
  485.     (progn
  486.       (setq old_dimzin (getvar "dimzin"))
  487.       ;; Turn off bit 8
  488.       (setvar "dimzin" (logand old_dimzin (~ 8)))
  489.       (setq a (rtos val))
  490.       ;; Turn on bit 8
  491.       (setvar "dimzin" (logior old_dimzin 8))
  492.       (setq b (rtos val units 15))
  493.       ;; Restore dimzin
  494.       (setvar "dimzin" old_dimzin)
  495.       ;; Fuzz factor used in equality check.
  496.       (if (equal (distof a) (distof b) 0.00000000000001) a b)
  497.     )
  498.   )
  499. );defun my-rtos2
  500.  
  501. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  502.  
  503. (defun my-overk-primitives2 ( ss fuz ignore /
  504.                                       flt lst gcode genprops n na e1 tp a b gen c d xv
  505.                                       vlst tmp alst lst2 lst3 j len k
  506.                                     )
  507.  
  508.  (acet-ss-clear-prev)
  509.  (command "_.select" ss)
  510.  (while (wcmatch (getvar "cmdnames") "*SELECT*") (command ""))
  511.  (setq flt '((-4 . "<OR")
  512.               (0 . "LINE") (0 . "ARC") (0 . "CIRCLE") (0 . "LWPOLYLINE")
  513.               (-4 . "<AND")
  514.                (0 . "POLYLINE")
  515.               (-4 . "<NOT") (-4 . "&") (70 . 88) (-4 . "NOT>") ;8 16 64 not 3dpoly mesh or pface mesh
  516.               (-4 . "AND>")
  517.              (-4 . "OR>")
  518.             )
  519.         ss (ssget "_p" flt)
  520.  );setq
  521.  (if (not ss)
  522.      (setq ss (ssadd))
  523.  );if
  524.  
  525.  
  526.  ;; build a general props list of group codes the does not include any gcs from the ignore list
  527.  ;; layer       8
  528.  ;; linetype    6
  529.  ;; thickness   39
  530.  ;; color       62
  531.  ;; lweight     370
  532.  ;; plotstyle   390
  533.  
  534.  (setq lst '(8 6 39 62 370 390));setq   ;; general properties
  535.  (foreach gcode lst
  536.   (if (not (member gcode ignore))
  537.       (setq genprops (cons gcode genprops))
  538.   );if
  539.  );foreach
  540.  (setq lst nil)
  541.  
  542.  (setq len (sslength ss)
  543.          k (/ len 5)
  544.          j 1
  545.  )
  546.  (acet-ui-progress-init "Gathering line, arc and circle data " len)
  547.  
  548.  (setq n 0)
  549.  (repeat (sslength ss)
  550.   (setq  na (ssname ss n)
  551.         lst nil
  552.   );setq
  553.  
  554.   (cond
  555.    ((and (setq e1 (entget na)
  556.                tp (cdr (assoc 0 e1))
  557.          );setq
  558.          (= tp "LINE")
  559.     );and
  560.     (setq     a (cdr (assoc 10 e1))
  561.               b (cdr (assoc 11 e1))
  562.             lst (list a b na)
  563.             gen (my-over-data2 e1 fuz genprops)
  564.     );setq
  565.    );cond #1
  566.  
  567.    ((or (= tp "ARC")
  568.         (= tp "CIRCLE")
  569.     );or
  570.     (setq   a (cdr (assoc 50 e1))
  571.             b (cdr (assoc 51 e1))
  572.             c (cdr (assoc 10 e1))                       ;; center
  573.             d (cdr (assoc 40 e1))                       ;; radius
  574.             c (list (acet-calc-round (car c) fuz)
  575.                     (acet-calc-round (cadr c) fuz)
  576.                     (acet-calc-round (caddr c) fuz)
  577.               );list
  578.             d (acet-calc-round d fuz)
  579.            xv (cdr (assoc 210 e1))
  580.            xv (list (acet-calc-round (car xv) 0.00000001)
  581.                     (acet-calc-round (cadr xv) 0.00000001)
  582.                     (acet-calc-round (caddr xv) 0.00000001)
  583.               );list
  584.           gen (list 1                                           ;; arc type
  585.                     c                                           ;; center
  586.                     d                                           ;; radius
  587.                     xv                                          ;; extrusion vector (slightly rounded)
  588.                     (my-over-get2 e1 genprops)  ;; general props
  589.               );list
  590.     );setq
  591.     (if (not a)
  592.         (setq a 0.0
  593.               b (+ pi pi)
  594.         );setq then circle
  595.     );if
  596.     (setq lst (list (cdr (assoc 10 e1))         ;; real center
  597.                     (cdr (assoc 40 e1))         ;; real radius
  598.                     a                           ;; start angle
  599.                     b                           ;; end angle
  600.                     na
  601.               );list
  602.     );setq
  603.    );cond #2
  604.   );cond close
  605.  
  606.   (if (= j k)
  607.       (progn
  608.        (acet-ui-progress-safe (fix (* 0.5 n)))
  609.        (setq j 1)
  610.       );progn then
  611.       (setq j (+ j 1))
  612.   );if
  613.  
  614.   (if lst
  615.       (setq vlst (cons (list gen lst);list
  616.                        vlst
  617.                  );cons
  618.       );setq then
  619.   );if
  620.  (setq n (+ n 1));setq
  621.  );repeat
  622.  
  623.  (setq j (/ len 2));setq
  624.  (acet-ui-progress-safe j)
  625.  
  626.  ;;The approach:
  627.  ;; -split in two: lines and arcs
  628.  ;; for lines:
  629.  ;; -sort by y-intercept
  630.  ;; for arcs:
  631.  ;; - sort by radius
  632.  ;; -lines...
  633.  ;;  - Use a while loop to group the lines with identical y-intercept
  634.  ;;  - Then foreach group use acet-list-group-by-assoc to split into
  635.  ;;    truly unique groups.
  636.  ;;    Assemble the main list along the way using cons for length of 1
  637.  ;;    and append for greater length.
  638.  ;; - arcs...
  639.  ;;   Handle arcs in same as lines but use radius instead of y-int.
  640.  ;;
  641.  
  642.  
  643.  (setq vlst (vl-sort vlst
  644.                      '(lambda ( a b )
  645.                        (> (car (car a)) (car (car b)))  ;0 or 1 (line or arc respectively)
  646.                       )
  647.             )
  648.  );setq
  649.  (while (and (setq a (car vlst))
  650.              (= (car (car a)) 1)
  651.         );and
  652.   (setq alst (cons a alst)
  653.         vlst (cdr vlst)
  654.   );setq
  655.  );while
  656.  
  657.  
  658.  (setq j (+ j (fix (* 0.05 len))))
  659.  (acet-ui-progress-safe j)
  660.  
  661.  (setq vlst (vl-sort vlst                       ;; sort the line list
  662.                      '(lambda ( a b )
  663.                        (setq a (car a)
  664.                              b (car b)
  665.                        )
  666.                        (< (nth 2 a) (nth 2 b))  ;0 slope y-int  
  667.                       )
  668.             )
  669.  );setq
  670.  
  671.  (setq j (+ j (fix (* 0.2 len))))
  672.  (acet-ui-progress-safe j)
  673.  
  674.  (setq alst (vl-sort alst                       ;; sort the arc list
  675.                      '(lambda ( a b )
  676.                        (setq a (car a)
  677.                              b (car b)
  678.                        )
  679.                        (< (nth 2 a) (nth 2 b))  ;1 center radius  
  680.                       )
  681.             )
  682.  );setq
  683.  
  684.  (setq j (+ j (fix (* 0.1 len))))
  685.  (acet-ui-progress-safe j)
  686.  
  687.  (while (setq lst (car vlst))                   ;; group by items that have save y-int
  688.   (setq vlst (cdr vlst)
  689.            a (nth 2 (car lst))  ;y-int
  690.         lst2 (list lst)
  691.   );setq
  692.   (while (and (setq b (car vlst))
  693.               (equal a
  694.                      (nth 2 (car b))
  695.               );equal
  696.          );and
  697.    (setq vlst (cdr vlst)
  698.          lst2 (cons b lst2)
  699.    );setq
  700.   );while
  701.   (setq lst3 (cons lst2 lst3));setq
  702.  );while
  703.  
  704.  (setq j (+ j (fix (* 0.05 len))))
  705.  (acet-ui-progress-safe j)
  706.  
  707.  (setq vlst nil
  708.        lst2 nil
  709.  );setq
  710.  (foreach lst lst3                              ;; for each group of equal y-int, group by identical car
  711.   (setq lst2 (acet-list-group-by-assoc lst))
  712.   (if (equal 1 (length lst2))
  713.       (setq vlst (cons (car lst2) vlst))
  714.       (setq vlst (append lst2 vlst))
  715.   );if
  716.  );foreach
  717.  
  718.  (setq lst3 nil)
  719.  (while (setq lst (car alst))
  720.   (setq alst (cdr alst)
  721.            a (nth 2 (car lst))  ;radius
  722.         lst2 (list lst)
  723.   );setq
  724.   (while (and (setq b (car alst))
  725.               (equal a
  726.                      (nth 2 (car b))
  727.               );equal
  728.          );and
  729.    (setq alst (cdr alst)
  730.          lst2 (cons b lst2)
  731.    );setq
  732.   );while
  733.   (setq lst3 (cons lst2 lst3));setq
  734.  );while
  735.  
  736.  (setq j (+ j (fix (* 0.05 len))))
  737.  (acet-ui-progress-safe j)
  738.  
  739.  (setq alst nil
  740.        lst2 nil
  741.  );setq
  742.  (foreach lst lst3
  743.   (setq lst2 (acet-list-group-by-assoc lst))
  744.   (if (equal 1 (length lst2))
  745.       (setq alst (cons (car lst2) alst))
  746.       (setq alst (append lst2 alst))
  747.   );if
  748.  );foreach
  749.  
  750.  (acet-ui-progress-done)
  751.  
  752.  (append vlst alst)
  753. );defun my-overkill-ss->primitives
  754.  
  755.        
  756. (princ)
  757.  

Оффлайн altverАвтор темы

  • ADN OPEN
  • ***
  • Сообщений: 118
  • Карма: 2
Re: Selection sets
« Ответ #20 : 31-01-2020, 13:56:55 »
Примите извинения за его размер... :)

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Re: Selection sets
« Ответ #21 : 31-01-2020, 14:03:49 »
Импирическим путем понял, что он накапливает наборы. Хотя может я и не прав...
Разбирайся с этим кодом, а не пытайся чистить наборы моим кодом. Тем более, что большинство функций с префиксом (acet-ss-*) - это функции, написанные на ObjectARX и работают с наборами они по-своему.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн altverАвтор темы

  • ADN OPEN
  • ***
  • Сообщений: 118
  • Карма: 2
Re: Selection sets
« Ответ #22 : 31-01-2020, 14:09:18 »
Спасибо!

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Re: Selection sets
« Ответ #23 : 31-01-2020, 14:49:56 »
В качестве первого приближения:
my-overk-primitives2 - зачем выбирать набор? Причем дважды - один раз командным методом, второй - через ssget.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн altverАвтор темы

  • ADN OPEN
  • ***
  • Сообщений: 118
  • Карма: 2
Re: Selection sets
« Ответ #24 : 31-01-2020, 21:37:01 »
В процессе работы нобходимо узнать, что находится под полилинией.(таких полилиний сотни). При помощи QSelect создаем наборы и их анаилзируем. Однако даже если наборам присваивать одинаковые имена, они накапливатся и Вашим методом не удаяются...
прилагаю лисп

Код - Auto/Visual Lisp [Выбрать]
  1. ;;-------------------------------------------------------------  EntForKontur -------------------------------------------------------------  
  2. ;;    EntForKontur - определяет объекты лежащие полностью под колнтуром
  3.   ;;  Org -  контур определенмия
  4.   ;;  spisLay - список слоев вида :   ((-4 . "<OR") (8 . "CALBLOCK") (8 . "WALL 10") (8 . "WALL 20") (8 . "columns") (-4 . "OR>"))
  5. (defun EntForKontur (Ogr spisLay / lstent1 lstograda ss11 lstSs11 pt1E pt2E pt0E   r ang ang1
  6.                                       ob  pt1aE pt2aE param pt51)
  7.  
  8.  
  9.     (setq obOgrada (vlax-ename->vla-object Ogr ))
  10.                        
  11.     (setq pointsnewECO  (pl-get-coors&width&bulge Ogr)
  12.             pointECO (append (car pointsnewECO) (list (car (car pointsnewECO ))))
  13.             KrivECO (cadr pointsnewECO))
  14.  
  15.  
  16.     (setq lstPost nil)
  17.     (setq    lstEnt1 nil
  18.                lstOgrada nil)
  19.  
  20.     (setq ss11 (ssget "cp" pointEco spisLay))   ;;sekushij
  21.     (setq lstSs11 ( pl:selset-to-enamelist ss11))
  22.   (setq ss11 nil)
  23.   (setq ss11 (ssget "WP" pointEco spisLay))  ;mnogougolnikom
  24.     (setq lstSs22 ( pl:selset-to-enamelist ss11))
  25.   (setq ss11 nil)
  26.  
  27.  
  28.   (foreach item1 lstSS11
  29.       (if (null (member item1 lstss22))
  30.           (setq lstograda (append lstOgrada (list item1)))
  31.       )
  32.   )  
  33. (setq ss11 ni)
  34.  
  35.  (command "HIDEOBJECTS" ogr "")
  36.     (setq lstOgrada1 nil)        
  37.      ;;==================================== выбрать тока те что лежат на контуре или хотябы частично лежат ================================================
  38.     (setq ij 0)
  39.     (foreach item1 lstOgrada
  40.       (if (> ij 6)(setq aa 2))
  41.       (if (and item1 (entget item1)) (progn
  42.       (setq item item1)
  43.       (setq ob (vlax-ename->vla-object item ))
  44.       (if (= (cdr (assoc 0 (entget item))) "LINE")
  45.           (setq pt1a (cdr (assoc 10 (entget item)))
  46.                 pt2a (cdr (assoc 11 (entget item)))
  47.                 pt51 (polar pt1a (angle pt1a pt2a) (/ (distance pt1a pt2a) 2.0)))
  48.  
  49.           (setq pt51 (vlax-curve-getPointAtDist  ob (/ (vlax-curve-getDistAtPoint ob (vlax-curve-getEndPoint ob)) 2.0))
  50.                 pt1a (vlax-curve-getStartPoint  ob)
  51.                 pt2a (vlax-curve-getEndPoint  ob))
  52.          
  53.       );;if    
  54.        
  55.    
  56.       (cond
  57.         ( (= (strcase (cdr (assoc 0 (entget item)))) "LINE")
  58.              (setq pt1a (cdr (assoc 10 (entget item)))
  59.                       pt2a (cdr (assoc 11 (entget item))))
  60.        
  61.           (if (and (equal pt1a (vlax-curve-getclosestpointto Ogr pt1a) 1.0)
  62.                    (equal pt2a (vlax-curve-getclosestpointto Ogr pt2a) 1.0))
  63.               (progn  ;; лежит полностью на ЕСО
  64.                         (setq lstOgrada1 (append   lstOgrada1 (list (list item pt1a pt2a pt51))))
  65.                      
  66.               );;prg лежит полностью на ЕСО
  67.            
  68.               (progn      ;; не лежит полностью на есо
  69.                           (setq obj (entlast)
  70.                                 lstObj nil)
  71.                           ;(BreakObject item Ogr )
  72.                 (if (>= (read (substr (getvar "ACADVER") 1 4)) 23.1)  ;; >=2020
  73.                           (setq lstObj (BreakNew20 item  Ogr))
  74.                           (setq lstObj (BreakNew20 item  Ogr))
  75.                 )
  76.                        (if (null lstObj)(progn
  77.                           ;;Процедура деления примитива item  полилинией Org          
  78.                               (BreakObject item Ogr )        
  79.                               (setq     oo    (entnext obj))
  80.                               (while (not (null oo))
  81.                                    (if (and (/= (cdr (assoc 0 (entget oo))) "ATTRIB")
  82.                                             (/= (cdr (assoc 0 (entget oo))) "SEQEND"))
  83.                                        (setq lstObj (append lstObj (list oo)))
  84.                                    )  
  85.                                    (setq  oo    (entnext oo))
  86.                               );;whil
  87.                               (setq lstObj (append lstObj (list item)))
  88.                            ))
  89.                
  90.                           (foreach it lstobj
  91.                             (setq itt1 it)
  92.                             (if (and itt1 (entget itt1))(progn
  93.                                 (setq pt1a (cdr (assoc 10 (entget itt1)))
  94.                                      pt2a (cdr (assoc 11 (entget itt1))))
  95.                                (command "point" pt1a)
  96.                                (setq ww1 (entlast))
  97.                                (command "point" pt2a)
  98.                                (setq ww2 (entlast))
  99.                                (entdel ww1) (entdel ww2)
  100.                                    
  101.                               (if (and (equal pt1a (vlax-curve-getclosestpointto Ogr pt1a) 1.0)
  102.                                      (equal pt2a (vlax-curve-getclosestpointto Ogr pt2a) 1.0))
  103.                                 (progn  ;; лежит полностью на ЕСО
  104.                                     (setq lstOgrada1 (append   lstOgrada1 (list (list itt1 pt1a pt2a pt51))))
  105.                        
  106.                                 );;prg
  107.                                 (setq lstPost (append lstPost (list itt1)))
  108.                               );;if
  109.                            ));;if
  110.                            
  111.  
  112.                            
  113.                           );;for
  114.               ;       |;
  115.                           (if (and itt1 (entget itt1))(progn
  116.                                 (setq pt1a (cdr (assoc 10 (entget itt1)))
  117.                                       pt2a (cdr (assoc 11 (entget itt1))))
  118.                            
  119.                               (if (and (equal pt1a (vlax-curve-getclosestpointto Ogr pt1a) 1.0)
  120.                                        (equal pt2a (vlax-curve-getclosestpointto Ogr pt2a) 1.0))
  121.                                   (progn  ;; лежит полностью на ЕСО
  122.                                     (setq lstOgrada1 (append   lstOgrada1 (list (list itt1 pt1a pt2a pt51))))
  123.                                  
  124.                                   );;prg
  125.                               );;if    
  126.                              
  127.                              
  128.                           ));;if
  129.                           (setq lstPost (append lstPost  itNo))
  130.  
  131.               );;prg
  132.           );;if  
  133.         );;LINe
  134.         ( (= (strcase (cdr (assoc 0 (entget item)))) "ARC")
  135.           (setq cent (cdr (assoc 10 (entget item)))
  136.                  R (cdr (assoc 40 (entget item))))
  137.           (setq  pt1a (polar cent (cdr (assoc 50 (entget item))) R)
  138.                  pt2a (polar cent (cdr (assoc 51 (entget item))) R)
  139.           )      
  140.            
  141.           (if (and (equal pt1a (vlax-curve-getclosestpointto Ogr pt1a) 0.01)
  142.                    (equal pt2a (vlax-curve-getclosestpointto Ogr pt2a) 0.01))
  143.                  (progn  ;;
  144.                     (setq param (fix (setq par (vlax-curve-getparamatpoint item pt51))))
  145.                     (if (setq info (assoc param lstEnt1))(progn
  146.                         (setq pos (position info lstEnt1))
  147.                         (if (null (member item (cdr info)))
  148.                             (setq   info (append info (list (list  par  item )))
  149.                                     lstEnt1 (lp_changeList lstEnt1  pos Info))
  150.                         );;if  
  151.                         );;prg
  152.                         (setq lstEnt1 (append lstEnt1 (list (list param    (list  par item )))))
  153.                     );;if
  154.                     (setq lstOgrada1 (append   lstOgrada1 (list (list item pt1a pt2a pt51))))
  155.                    ;(setq lstOgrada1 (append   lstOgrada1  (list item)))
  156.            )
  157.            (setq lstPost (append lstPost (list it)))
  158.             );;if
  159.           ;));;if  
  160.         );;arc
  161.         ( T
  162.           (setq lstOgrada1 (append   lstOgrada1 (list (list item pt1a pt2a pt51))))
  163.           ;(setq lstOgrada1 (append   lstOgrada1  (list item)))
  164.         )
  165.       );;cond
  166.       ));if
  167.       (setq ij (1+ ij))
  168.     );;for
  169.     lstOgrada1
  170. );;  end fun  EntForKontur     

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Re: Selection sets
« Ответ #25 : 31-01-2020, 22:04:07 »
Советую напрочь забыть про наборы и формировать списки примитивов чисто программно. Это усложнит код раз эдак в дцать, но зато работать будет.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн altverАвтор темы

  • ADN OPEN
  • ***
  • Сообщений: 118
  • Карма: 2
Re: Selection sets
« Ответ #26 : 31-01-2020, 22:40:32 »
Да уж, обрадовал...

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Re: Selection sets
« Ответ #27 : 31-01-2020, 23:45:41 »
Так что надо в результате? По каким-то хитрым и особым условиям выполнить overkill?
Определить, лежит ли примитив в каком-либо контуре можно и без использования наборов, как мне кажется.
Проблема будет при обработке блоков, но не думаю, что это нерешаемая проблема (можно хоть новый документ создавать, в него копировать элементы, разбивать как хочется - и анализировать результаты. И это всего лишь один из возможных способов).
Может быть, я ошибаюсь - это запросто.
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!

Оффлайн altverАвтор темы

  • ADN OPEN
  • ***
  • Сообщений: 118
  • Карма: 2
Re: Selection sets
« Ответ #28 : 01-02-2020, 09:56:16 »
Ну, и каким способом Вы предлагаете определить, что находится под полилинией или внутри замкнутого контура без QSelect? Точнее без ssget?
« Последнее редактирование: 01-02-2020, 10:46:58 от altver »

Оффлайн altverАвтор темы

  • ADN OPEN
  • ***
  • Сообщений: 118
  • Карма: 2
Re: Selection sets
« Ответ #29 : 01-02-2020, 11:07:03 »
По большому счету нужно найти источник незакрытых наборов. Чаще всего это какая-то не вполне корректная lisp-программа, которая не чистит набор.

У меня есть сотня замкнутых контуров (полилнии). В цикле я определяю, каке объекты находятся внутри контура, какие под ним и какие пересекают его. Естественно я создаю наборы (ssget), присваиваю им одно и тоже имя и в каждом цикле я их обнуляю... в этом месте в коде происходит обвал... (exceeded maximum number of selection sets). Что я неправильно длаю? Где ошибаюсь?
 Заранее огромное спасибо!