Topic: How to join the sub list while contains same item?

[cjw]

No,more simple than that.
see the under picture.

[cjw]

Line entity have same endpoint or startpoint foreach, collect to a sub list.
Another stupid idea to realizing it.But very slowly when too many lines.

Code: [Select]

(defun C:EG ()
  ;; C-ANGLE-PI-FUZZ
  (defun C-ANGLE-PI-FUZZ (#ANGLE FUZZ / ANG)
    (setq ANG #ANGLE)
    (setq ANG (if (< ANG 0)
(+ (rem ANG pi) pi)
(rem ANG pi)
     )
    )
    (if (or (equal ANG 0 FUZZ)
   (equal ANG pi FUZZ)
   (equal ANG (* 2 pi) FUZZ)
)
      (setq ANG 0.0)
      ANG
    )
  )
  ;; C-LIST-DIVIDE-F
  (defun C-LIST-DIVIDE-F (LST FUN / RETURN TMP I)
    (setq RETURN '())
    (while LST
      (setq *X* (car LST))
      (setq TMP (vl-remove-if-not FUN LST))
      (and TMP (setq RETURN (cons TMP RETURN)))
      (setq LST (vl-remove-if FUN LST))
    )
    (reverse RETURN)
  )
  ;; C-ENTNEXT->SS
  (defun C-ENTNEXT->SS (ENT / SS)
    (setq SS (ssadd))
    (while (setq ENT (entnext ENT))
      (or (vlax-erased-p ENT)
 (ssadd ENT SS)
      )
    )
    SS
  )
  ;; C-SS->ENAMES
  (defun C-SS->ENAMES (SS / E I RETURN)
    (repeat (setq I (sslength SS))
      (and (setq E (ssname SS (setq I (1- I))))
  (null (vlax-erased-p E))
  (setq RETURN (cons E RETURN))
      )
    )
    RETURN
  )
  ;; -------------Main--------------
  (setq LST '())
  (setq SS (ssget '((0 . "LINE"))))
  (repeat (setq I (sslength SS))
    (and (setq E (ssname SS (setq I (1- I))))
(setq ANG (vla-get-angle (vlax-ename->vla-object E)))
(setq ANG (C-ANGLE-PI-FUZZ ANG 0.01))
(setq LST (cons (list E ANG) LST))
    )
  )
  (setq LST (C-LIST-DIVIDE-F
     LST
     '(lambda (X)
(equal (cadr X) (cadr *X*) 1e-6)
      )
   )
  )
  (setq ENTLIST '())
  (foreach X LST
    (setq ENTS (mapcar 'car X))
    (setq SS (ssadd))
    (foreach E ENTS
      (ssadd E SS)
    )
    (setq EL (entlast))
    (if (and SS (/= (sslength SS) 0))
      (progn
(setq PEDITACCEPT (getvar "PEDITACCEPT"))
(setvar "PEDITACCEPT" 1)
(command "._PEDIT" "M" SS "" "J" "0" "")
(setvar "PEDITACCEPT" PEDITACCEPT)
      )
    )
    (setq SSS (C-ENTNEXT->SS EL))
    (setq ENTS (C-SS->ENAMES SSS))
    (and ENTS
(setq ENTLIST (append ENTS ENTLIST))
    )
  )
  (setq I 0)
  (foreach E ENTLIST
    (vla-put-color (vlax-ename->vla-object E) (setq I (1+ I)))
 [color=red]   (command "._EXPLODE" E);_[/color]
  )
  (princ)
)


The result show:

[cjw]

Any good idea?
Thank you all.

[gile]

Hi,

So, I wasn't so far with my first reply.
I only added a test to evaluate if segments (points pairs) are colinear.

Code: [Select]

(defun LinesAutoJoin (seglst / sub n tmp result)
  (while seglst
    (setq sub (car seglst)
  seglst (cdr seglst)
  n 0
    )
    (while (and seglst (< n (length seglst)))
      (setq tmp (car seglst))
      (if (null
    (inters (car tmp) (cadr tmp) (car sub) (cadr sub))
  )
(cond
  ((equal (car tmp) (cadr sub) 1e-9)
   (setq sub   (list (car sub) (cadr tmp))
seglst (cdr seglst)
n     0
   )
  )
  ((equal (car tmp) (car sub) 1e-9)
   (setq sub   (list (cadr tmp) (cadr sub))
seglst (cdr seglst)
n     0
   )
  )
  ((equal (cadr tmp) (cadr sub) 1e-9)
   (setq sub   (list (car sub) (car tmp))
seglst (cdr seglst)
n     0
   )
  )
  ((equal (cadr tmp) (car sub) 1e-9)
   (setq sub   (list (car tmp) (cadr sub))
seglst (cdr seglst)
n     0
   )
  )
  (T
   (setq seglst (append (cdr seglst) (list tmp))
n     (1+ n)
   )
  )
)
(setq seglst (append (cdr seglst) (list tmp))
      n     (1+ n)
)
      )
    )
    (setq result (cons sub result))
  )
)


(defun c:test (/ n ss ent elst seglst)
  (if (setq n  -1
    ss (ssget '((0 . "LINE")))
      )
    (progn
      (while (setq ent (ssname ss (setq n (1+ n))))
(setq elst  (entget ent)
      seglst (cons (list (cdr (assoc 10 elst)) (cdr (assoc 11 elst)))
  seglst
    )
)
      )
      (setq n 0)
      (foreach p (LinesAutoJoin seglst)
(entmake
  (list
    '(0 . "LINE")
    (cons 10 (car p))
    (cons 11 (cadr p))
    (cons 62 (setq n (1+ n)))
  )
)
      )
      ;;(command "_.erase" ss "")
    )
  )
  (princ)
)

[cjw]

看来没有更快的办法了。
我用#3楼,#8,#16,#18的代码，都可以实现，
但是测试LINE.dwg都不快,这可能是LISP的极限了。
连我崇拜的gile的代码都要花很长的时间。

不想浪费大家时间了。这个贴子就先到这里了。
Thank you all.