Topic: sorting LINE entities by end points

[ribarm]

Hi...

I have list of enames of LINE entities in variable "elst"...
The question :
I want to sort that list by following criteria :
- the first enames should be LINE entities that have end points free - both ends are not touching other LINES from elst...
- next in list should come LINES that touch other LINES with one end point - other one is free...
- the last enames should be LINES that touch other LINES with both end points...

So how would this (vl-sort) look like...

Thanks, M.R.
P.S. I don't need this so this is just brainstorming task... Take your time and if you have solution you're most welcome to reply...

[ribarm]

I know that it could be done with this :

Code: [Select]

Code removed due to my mistake... OP's apology...
But I was hoping to see if someone could do it just with (vl-sort)...

M.R.

[Grrr1337]

Hi Marko, this is my attempt (not exactly what you want):

Code: [Select]

(defun test ( elst / nLst RtnLst Lst s1 e1 s2 e2 flg )

(setq nLst (list))
(setq RtnLst (list))
(setq Lst ; assoc list, where every item is (<handle> <StartPt> <EndPt>)
(mapcar (function (lambda (x) (mapcar 'cdr (mapcar 'assoc (list 5 10 11) (list x x x))))) elst)
); setq Lst
(foreach a Lst ; compare every line with every line, using double (foreach)
(foreach b Lst
(and (not (equal (car a) (car b))) ; handles are not equal, continue
(setq
s1 (cadr a) ; first line startpt
e1 (caddr a) ; first line endpt
s2 (cadr b) ; second line startpt
e2 (caddr b) ; second line endpt
); setq
(cond ; flag: 0 - lines don't share points;;; 1 - lines share one of their points;;; 2 - lines are ontop of each other (share both of their points)
(
(not ; lines don't share points
(or
(equal s1 s2 1e-8)
(equal e1 e2 1e-8)
(equal s1 e2 1e-8)
(equal e1 s2 1e-8)
); or
); not
(setq flg 0)
)
(
(or ; lines share one of their points
(equal s1 s2 1e-8)
(equal e1 e2 1e-8)
(equal s1 e2 1e-8)
(equal e1 s2 1e-8)
); or
(setq flg 1)
)
(
(or ; lines are ontop of each other (share both of their points)
(and
(equal s1 s2 1e-8)
(equal e1 e2 1e-8)
)
(and
(equal s1 e2 1e-8)
(equal e1 s2 1e-8)
)
); or
(setq flg 2)
)
); cond
(setq nLst (append (list (list a flg) (list b flg)) nLst)) ; collect list where every item is: (<handle> <StartPt> <EndPt> <flag>)
); and
); foreach
); foreach
(mapcar (function (lambda (x) (cond ((not (member (car x) RtnLst)) (setq RtnLst (cons (car x) RtnLst)))))) ; remove the duplicate handles from the "nLst"
(mapcar (function (lambda (x) (nth x nLst))) (vl-sort-i (mapcar 'cadr nLst) '>)) ; sort the list by the <flag> value
)
RtnLst
); defun
Included some comments to understand easier whats happening.
Assuming you would use it like this:

Code: [Select]

(if (setq SS (ssget (list (cons 0 "LINE"))))
(repeat (setq i (sslength SS))
(setq elst (cons (entget (ssname SS (setq i (1- i)))) elst))
)
)
(mapcar 'handent (mapcar 'car (test elst)))
HTH

[ribarm]

Actually I've made mistake... I was thinking something like this :

1. || lines - both ends free
2. L lines - one end touch another one
3. [ lines - both ends touch 2 adjacent lines

So the code should look like this, but if someone knows better and faster - perhaps (vl-sort)...

Code: [Select]

(foreach e elst
  (cond
    ( (and
        (not
          (vl-some '(lambda ( x )
            (or
              (equal (cdr (assoc 10 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
              (equal (cdr (assoc 10 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
            )) (vl-remove e elst)
          )
        )
        (not
          (vl-some '(lambda ( x )
            (or
              (equal (cdr (assoc 11 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
              (equal (cdr (assoc 11 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
            )) (vl-remove e elst)
          )
        )
      )
      (setq el1 (cons e el1))
    )
    ( (or
        (and
          (vl-some '(lambda ( x )
            (or
              (equal (cdr (assoc 10 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
              (equal (cdr (assoc 10 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
            )
          ) (vl-remove e elst))
          (not
            (vl-some '(lambda ( x )
              (or
                (equal (cdr (assoc 11 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
                (equal (cdr (assoc 11 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
              )
            ) (vl-remove e elst))
          )
        )
        (and
          (not
            (vl-some '(lambda ( x )
              (or
                (equal (cdr (assoc 10 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
                (equal (cdr (assoc 10 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
              )
            ) (vl-remove e elst))
          )
          (vl-some '(lambda ( x )
            (or
              (equal (cdr (assoc 11 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
              (equal (cdr (assoc 11 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
            )
          ) (vl-remove e elst))
        )
      )
      (setq el2 (cons e el2))
    )
    ( (and
        (vl-some '(lambda ( x )
          (or
            (equal (cdr (assoc 10 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
            (equal (cdr (assoc 10 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
          )) (vl-remove e elst)
        )
        (vl-some '(lambda ( x )
          (or
            (equal (cdr (assoc 11 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
            (equal (cdr (assoc 11 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
          )) (vl-remove e elst)
        )
      )
      (setq el3 (cons e el3))
    )
  )
)
(setq elst (append el1 el2 el3))

M.R.

[Grrr1337]

I think that "Chain Selection" might help for the task, atleast looks similair in the performance.
BTW, what If there are lines like "X" (4 lines share the same vertex).

[ribarm]

BTW, what If there are lines like "X" (4 lines share the same vertex).

That "X" lines are actually "L" type - 2nd group of sorting... One end is touching shared point and other end is free...

[Grrr1337]

That "X" lines are actually "L" type - 2nd group of sorting... One end is touching shared point and other end is free...

Oh, right... well actually my suggestion should solve steps 1. and 2. as it compares every pair of lines from the list, and checks their vertices status.

1. || lines - both ends free
2. L lines - one end touch another one
3. [ lines - both ends touch 2 adjacent lines

Basically in that variable "nLst" is collected the info about relation of every pair of lines, but I just got confused with situation 3. so I'm leaving some picture for further clearance:

My initial thought was to use some kind of "ssget on a point", for each point from the lines's point list.

[ribarm]

Yes L2 from your picture is 3rd case... 2 other lines are 2nd case...

[Grrr1337]

BTW how do you check if your result is correct, heres my thought about that:

Code: [Select]

(defun LabelToCheck ( Lst / n )

(defun M-Text (pt str); LM
(entmakex (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 10 pt) (cons 1 str) (cons 71 5)))
)
(setq n 0)
(mapcar
(function
(lambda (o / ll ur)
(vla-getBoundingBox o 'll 'ur)
(M-Text
(apply 'mapcar (cons '(lambda (a b) (/ (+ a b) 2.)) (mapcar 'vlax-safearray->list (list ll ur)))); LM
(itoa (setq n (1+ n)))
)
)
)
(mapcar 'vlax-ename->vla-object Lst)
)
) (vl-load-com) (princ)
For example to see graphically the original positions of the lines inside the SS:

Code: [Select]

(LabelToCheck (mapcar (function (lambda (x) (cdr (assoc -1 x)))) elst))

[ribarm]

BTW how do you check if your result is correct, heres my thought about that:

You are right Grrr1337, I haven't tested my input... And yes it was not correct again, so I've checked it once again and now it's fine... How would I check - here is how :

Code: [Select]

(defun c:sortlinesbyendpts ( / ss elst el1 el2 el3 ssel1 ssel2 ssel3 )
  (setq ss (ssget '((0 . "LINE"))))
  (setq elst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (foreach e elst
    (cond
      ( (and
          (not
            (vl-some '(lambda ( x )
              (or
                (equal (cdr (assoc 10 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
                (equal (cdr (assoc 10 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
              )) (vl-remove e elst)
            )
          )
          (not
            (vl-some '(lambda ( x )
              (or
                (equal (cdr (assoc 11 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
                (equal (cdr (assoc 11 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
              )) (vl-remove e elst)
            )
          )
        )
        (setq el1 (cons e el1))
      )
      ( (or
          (and
            (vl-some '(lambda ( x )
              (or
                (equal (cdr (assoc 10 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
                (equal (cdr (assoc 10 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
              )
            ) (vl-remove e elst))
            (not
              (vl-some '(lambda ( x )
                (or
                  (equal (cdr (assoc 11 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
                  (equal (cdr (assoc 11 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
                )
              ) (vl-remove e elst))
            )
          )
          (and
            (not
              (vl-some '(lambda ( x )
                (or
                  (equal (cdr (assoc 10 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
                  (equal (cdr (assoc 10 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
                )
              ) (vl-remove e elst))
            )
            (vl-some '(lambda ( x )
              (or
                (equal (cdr (assoc 11 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
                (equal (cdr (assoc 11 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
              )
            ) (vl-remove e elst))
          )
        )
        (setq el2 (cons e el2))
      )
      ( (and
          (vl-some '(lambda ( x )
            (or
              (equal (cdr (assoc 10 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
              (equal (cdr (assoc 10 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
            )) (vl-remove e elst)
          )
          (vl-some '(lambda ( x )
            (or
              (equal (cdr (assoc 11 (entget e))) (cdr (assoc 10 (entget x))) 1e-6)
              (equal (cdr (assoc 11 (entget e))) (cdr (assoc 11 (entget x))) 1e-6)
            )) (vl-remove e elst)
          )
        )
        (setq el3 (cons e el3))
      )
    )
  )
  (setq elst (append el1 el2 el3))
  (if el1
    (progn
      (setq ssel1 (ssadd))
      (foreach e el1
        (ssadd e ssel1)
      )
      (prompt "\nSelected first type of lines... ENTER to CONTINUE...")
      (sssetfirst nil ssel1)
      (vl-catch-all-apply 'grread)
    )
    (prompt "\nNo lines of first type in specified selection set of lines...")
  )
  (if el2
    (progn
      (setq ssel2 (ssadd))
      (foreach e el2
        (ssadd e ssel2)
      )
      (prompt "\nSelected second type of lines... ENTER to CONTINUE...")
      (sssetfirst nil ssel2)
      (vl-catch-all-apply 'grread)
    )
    (prompt "\nNo lines of second type in specified selection set of lines...")
  )
  (if el3
    (progn
      (setq ssel3 (ssadd))
      (foreach e el3
        (ssadd e ssel3)
      )
      (prompt "\nSelected third type of lines... ENTER to CONTINUE...")
      (sssetfirst nil ssel3)
      (vl-catch-all-apply 'grread)
    )
    (prompt "\nNo lines of third type in specified selection set of lines...")
  )
  (sssetfirst nil nil)
  (princ)
)

M.R.
Thanks for your input Grrr1337...

[ribarm]

I was joking that I don't need this... Actually I need it as faster as it could be... Performance of this routine directly depends on this here discussed algorithm...
http://www.cadtutor.net/forum/showthread.php?98911-convert-lines-to-3d-polylines&s=459102492df2f025ea06f376d5ebe8ea&p=#6

So anyone... ? Any reply is welcome, or any thought or remark to make it even just slight faster...

[ribarm]

Well as you can see from the link from previous post, I did find alternative solution for the task OP there asked... And when I said that I need every possible optimization of code to be faster I meant every small thing even detail like switching from Vanilla to Visual... You may find it silly, but (vlax-curve-*) function is ab 10x faster than my previous used with (entget)... I've also changed (cond) function as last check is unnecessary - also switched positions inside (cond) as by my opinion it checks less things with smaller number of (vl-some) statements and that means that it's faster... So here is it till now from me... If someone thinks ab something I've missed, please jump in...

Code - Auto/Visual Lisp: [Select]

1. (defun c:sortlinesbyendpts ( / ss elst el1 el2 el3 ssel1 ssel2 ssel3 )
2.  
3.   (vl-load-com)
4.  
5.   (setq ss (ssget '((0 . "LINE"))))
6.   (setq elst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
7.   (foreach e elst
8.     (cond
9.       ( (and
10.           (not
11.             (vl-some '(lambda ( x )
12.               (or
13.                 (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6)
14.                 (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6)
15.               )) (vl-remove e elst)
16.             )
17.           )
18.           (not
19.             (vl-some '(lambda ( x )
20.               (or
21.                 (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6)
22.                 (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6)
23.               )) (vl-remove e elst)
24.             )
25.           )
26.         )
27.         (setq el1 (cons e el1))
28.       )
29.       ( (and
30.           (vl-some '(lambda ( x )
31.             (or
32.               (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6)
33.               (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6)
34.             )) (vl-remove e elst)
35.           )
36.           (vl-some '(lambda ( x )
37.             (or
38.               (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6)
39.               (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6)
40.             )) (vl-remove e elst)
41.           )
42.         )
43.         (setq el3 (cons e el3))
44.       )
45.       ( t
46.         ;|
47.         (or
48.           (and
49.             (vl-some '(lambda ( x )
50.               (or
51.                 (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6)
52.                 (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6)
53.               )
54.             ) (vl-remove e elst))
55.             (not
56.               (vl-some '(lambda ( x )
57.                 (or
58.                   (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6)
59.                   (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6)
60.                 )
61.               ) (vl-remove e elst))
62.             )
63.           )
64.           (and
65.             (not
66.               (vl-some '(lambda ( x )
67.                 (or
68.                   (equal (vlax-curve-getstartpoint e) (vlax-curve-getstartpoint x) 1e-6)
69.                   (equal (vlax-curve-getstartpoint e) (vlax-curve-getendpoint x) 1e-6)
70.                 )
71.               ) (vl-remove e elst))
72.             )
73.             (vl-some '(lambda ( x )
74.               (or
75.                 (equal (vlax-curve-getendpoint e) (vlax-curve-getstartpoint x) 1e-6)
76.                 (equal (vlax-curve-getendpoint e) (vlax-curve-getendpoint x) 1e-6)
77.               )
78.             ) (vl-remove e elst))
79.           )
80.         )
81.         |;
82.         (setq el2 (cons e el2))
83.       )
84.     )
85.   )
86.   (setq elst (append el1 el2 el3))
87.   (if el1
88.     (progn
89.       (setq ssel1 (ssadd))
90.       (foreach e el1
91.         (ssadd e ssel1)
92.       )
93.       (prompt "\nSelected first type of lines... ENTER to CONTINUE...")
94.       (sssetfirst nil ssel1)
95.       (vl-catch-all-apply 'grread)
96.     )
97.     (prompt "\nNo lines of first type in specified selection set of lines...")
98.   )
99.   (if el2
100.     (progn
101.       (setq ssel2 (ssadd))
102.       (foreach e el2
103.         (ssadd e ssel2)
104.       )
105.       (prompt "\nSelected second type of lines... ENTER to CONTINUE...")
106.       (sssetfirst nil ssel2)
107.       (vl-catch-all-apply 'grread)
108.     )
109.     (prompt "\nNo lines of second type in specified selection set of lines...")
110.   )
111.   (if el3
112.     (progn
113.       (setq ssel3 (ssadd))
114.       (foreach e el3
115.         (ssadd e ssel3)
116.       )
117.       (prompt "\nSelected third type of lines... ENTER to CONTINUE...")
118.       (sssetfirst nil ssel3)
119.       (vl-catch-all-apply 'grread)
120.     )
121.     (prompt "\nNo lines of third type in specified selection set of lines...")
122.   )
123.   (sssetfirst nil nil)
124.   (princ)
125. )
126.  

M.R.

[MP]

Haven't tested this (have nothing to test it on) but (in theory) this quickly refactored version may be faster:

Code: [Select]

(defun c:SortLinesByEndPts ( / f1 f2 m1 m2 m3 m4 tmp ss elst el1 el2 el3 ssel1 ssel2 ssel3 )
     
    (vl-load-com)
   
    ;;  Note: in the following functions variable 'e' is assumed to be a lexical global

    (defun f1 (x tmp)
        (vl-some
            (function
                (lambda (x / p)
                    (or
                        (equal
                            (setq p (vlax-curve-getstartpoint e))
                            (vlax-curve-getstartpoint x)
                            1e-6
                        )
                        (equal
                            p
                            (vlax-curve-getendpoint x)
                            1e-6
                        )
                    )
                )
            )
            tmp
        )
    )
   
    (defun f2 (x tmp)
        (vl-some
            (function
                (lambda (x / p)
                    (or
                        (equal
                            (setq p (vlax-curve-getendpoint e))
                            (vlax-curve-getstartpoint x)
                            1e-6
                        )
                        (equal
                            p
                            (vlax-curve-getendpoint x)
                            1e-6
                        )
                    )
                )
            )
            tmp
        )
    )

    (defun m1 (x tmp) (not (f1 x tmp)))
    (defun m2 (x tmp) (not (f2 x tmp)))
    (defun m3 (x tmp) (f1 x tmp))
    (defun m4 (x tmp) (f2 x tmp))

    (setq
        ss   (ssget '((0 . "LINE")))
        elst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    )

    (foreach e elst
        (cond
            ((and (m1 x (setq tmp (vl-remove e elst))) (m2 x tmp)) (setq el1 (cons e el1)))
            ((and (m3 x tmp) (m4 x tmp)) (setq el3 (cons e el3)))
            ((setq el2 (cons e el2)))
        )
    )
     
    (setq elst (append el1 el2 el3))
     
    (if el1
        (progn
            (setq ssel1 (ssadd))
            (foreach e el1 (ssadd e ssel1))
            (prompt "\nSelected first type of lines... ENTER to CONTINUE...")
            (sssetfirst nil ssel1)
            (vl-catch-all-apply 'grread)
        )
        (prompt "\nNo lines of first type in specified selection set of lines...")
    )
     
    (if el2
        (progn
            (setq ssel2 (ssadd))
            (foreach e el2 (ssadd e ssel2))
            (prompt "\nSelected second type of lines... ENTER to CONTINUE...")
            (sssetfirst nil ssel2)
            (vl-catch-all-apply 'grread)
        )
        (prompt "\nNo lines of second type in specified selection set of lines...")
    )
     
    (if el3
        (progn
            (setq ssel3 (ssadd))
            (foreach e el3 (ssadd e ssel3))
            (prompt "\nSelected third type of lines... ENTER to CONTINUE...")
            (sssetfirst nil ssel3)
            (vl-catch-all-apply 'grread)
        )
        (prompt "\nNo lines of third type in specified selection set of lines...")
    )

    (sssetfirst nil nil)

    (princ)
   
)
Edit: Why it may be faster: (1) formal function declarations (2) reduce repetitive (vl-remove e elst) and (vlax-curve-get* e) calls.

FWIW, cheers.

[mailmaverick]

Hi Ribarm,

It would be interesting to see in what application you are using this sort function.
Can you upload any drawing where this is being used. It would also help us to see which solution among various given by members is fastest.

[ribarm]

Hi Ribarm,

It would be interesting to see in what application you are using this sort function.
Can you upload any drawing where this is being used. It would also help us to see which solution among various given by members is fastest.

I don't have particular DWG, but I've already pointed where is algorithm used in reply #10...