Topic: Combining lists of point lists

[David Bethel]

I'm trying to sort and combine points list without a lot of luck

Code: [Select]


  (setq L1 '((0 0 0) (1 1 0) (1 2 1) (2 3 1))
        L2 '((22 3 1) (22 2 1) (22 0 0) (23 4 5))
        L3 '((3 4 5) (6 7 8) (9 10 11))
        L4 '((20 0 0) (21 1 0) (21 2 1) (22 3 1))
        L5 '((2 3 1) (2 2 1) (2 0 0) (3 4 5))
        L6 '((9 10 11) (12 13 12) (14 15 12))
        L7 '((23 4 5) (26 7 8) (29 10 11))
        L8 '((29 10 11) (32 13 12) (34 15 12)))


Since '(0 0 0) and (20 0 0) only occurs once as (car) and not as (last) of any list, I know they are a starting points.

Then trying to search for the (last) of L1 as the (car) of another list is where I'm coming up short.

Code: [Select]


Needs to return:
  L1 + L5 + L3 + L6
  '((0 0 0) (1 1 0) (1 2 1) (2 3 1) (2 2 1) (2 0 0) (3 4 5)
    (6 7 8) (9 10 11) (12 13 12) (14 15 12))

and:
  L4 + L2 + L7 + L8
  '((20 0 0) (21 1 0) (21 2 1) (22 3 1) (22 2 1) (22 0 0) (23 4 5)
    (26 7 8) (29 10 11) (32 13 12) (34 15 12)))


(append L1 (cdr L5)) puts them together.

Then I would remove l1 from the search.  I think....

And then knowing when to finish...


Any ideas or suggestions  -David

[MP]

hint: (assoc (last sublist) masterlist) ... <not @ a pc w/acad right now>

[Lee Mac]

Not easy without VL, but this seems to work:

Code: [Select]

(defun PointGroup ( l / _remove a )

  (defun _remove ( x l )
    (if l
      (if (equal (car l) x)
        (cdr l)
        (cons (car l) (_remove x (cdr l)))
      )
    )
  )
 
  (if l
    (progn
      (while
        (progn
          (cond
            ( (setq a (assoc (last (car l)) (cdr l)))

              (setq l (cons (append (car l) (cdr a)) (_remove a (cdr l))))
            )
            ( (setq a (assoc (caar l) (mapcar 'reverse l)))

              (setq l (cons (append (reverse (cdr a)) (car l)) (_remove (reverse a) (cdr l))))
            )
          )
        )
      )
      (cons (car l) (PointGroup (cdr l)))
    )
  )
)

Code: [Select]

(PointGroup
  (
    ((0 0 0) (1 1 0) (1 2 1) (2 3 1))
    ((22 3 1) (22 2 1) (22 0 0) (23 4 5))
    ((3 4 5) (6 7 8) (9 10 11))
    ((20 0 0) (21 1 0) (21 2 1) (22 3 1))
    ((2 3 1) (2 2 1) (2 0 0) (3 4 5))
    ((9 10 11) (12 13 12) (14 15 12))
    ((23 4 5) (26 7 8) (29 10 11))
    ((29 10 11) (32 13 12) (34 15 12))
  )
)


Code: [Select]

(
  ((0 0 0) (1 1 0) (1 2 1) (2 3 1) (2 2 1) (2 0 0) (3 4 5) (6 7 8) (9 10 11) (12 13 12) (14 15 12))
  ((20 0 0) (21 1 0) (21 2 1) (22 3 1) (22 2 1) (22 0 0) (23 4 5) (26 7 8) (29 10 11) (32 13 12) (34 15 12))
)


[David Bethel]

Not having much luck yet.

this should end up 1 single list

Code: [Select]


(setq zl '
(((60257.9 95710.0 8550.0) (60097.1 95860.7 8550.0) (60000.4 96058.8 8550.0) (59980.6 96278.3 8550.0) (60040.2 96490.6 8550.0)) ((62495.9 101497.0 8550.0) (60040.2 96490.6 8550.0)) ((64519.5 92973.2 8550.0) (60257.9 95710.0 8550.0)) ((63074.4 102677.0 8770.0) (63101.4 102741.0 8770.0) (63120.9 102808.0 8770.0) (63132.7 102876.0 8770.0) (63136.6 102945.0 8770.0)) ((63074.4 102677.0 8770.0) (62928.0 102379.0 8770.0)) ((62928.0 102379.0 8770.0) (62910.5 102343.0 8768.7) (62893.0 102307.0 8764.79) (62875.7 102272.0 8758.3) (62858.6 102237.0 8749.25)) ((62858.6 102237.0 8749.25) (62565.3 101639.0 8570.75)) ((62565.3 101639.0 8570.75) (62548.2 101604.0 8561.7) (62530.9 101569.0 8555.21) (62513.4 101533.0 8551.3) (62495.9 101497.0 8550.0)) ((65151.6 92567.3 8750.0) (65085.6 92609.7 8750.0)) ((65085.6 92609.7 8750.0) (65018.7 92652.6 8744.79) (64953.0 92694.8 8729.25) (64889.5 92735.6 8703.64) (64829.4 92774.2 8668.41)) ((65151.6 92567.3 8750.0) (65319.8 92459.2 8750.0)) ((64829.4 92774.2 8668.41) (64775.7 92808.7 8631.59)) ((64775.7 92808.7 8631.59) (64715.6 92847.3 8596.36) (64652.1 92888.0 8570.75) (64586.4 92930.2 8555.21) (64519.5 92973.2 8550.0)) ((76579.2 85228.5 8750.0) (65319.8 92459.2 8750.0)) ((76579.2 85228.5 8750.0) (76655.4 85186.9 8750.0) (76736.8 85156.6 8750.0) (76821.7 85138.1 8750.0) (76908.3 85131.9 8750.0)) ((76908.3 85131.9 8750.0) (76943.5 85131.9 8750.0)) ((77248.0 85131.9 8668.41) (77176.5 85131.9 8703.64) (77101.1 85131.9 8729.25) (77023.0 85131.9 8744.79) (76943.5 85131.9 8750.0)) ((77778.0 85131.9 8233.07) (77507.7 85131.9 8496.69)) ((77507.7 85131.9 8496.69) (77479.7 85131.9 8522.34) (77450.2 85131.9 8546.2) (77419.2 85131.9 8568.17) (77387.0 85131.9 8588.17)) ((77387.0 85131.9 8588.17) (77248.0 85131.9 8668.41)) ((77778.0 85131.9 8233.07) (77869.6 85131.9 8159.51) (77973.7 85131.9 8104.92) (78086.3 85131.9 8071.34) (78203.2 85131.9 8060.0))))

but I get 8 with PointGroup

[ronjonp]

Maybe this?:

Code: [Select]

(defun c:test (/ l1 l2 l3 l4 l5 l6 l7 l8 lst out x y)
  (setq l1 '((0 0 0) (1 1 0) (1 2 1) (2 3 1))
l2 '((22 3 1) (22 2 1) (22 0 0) (23 4 5))
l3 '((3 4 5) (6 7 8) (9 10 11))
l4 '((20 0 0) (21 1 0) (21 2 1) (22 3 1))
l5 '((2 3 1) (2 2 1) (2 0 0) (3 4 5))
l6 '((9 10 11) (12 13 12) (14 15 12))
l7 '((23 4 5) (26 7 8) (29 10 11))
l8 '((29 10 11) (32 13 12) (34 15 12))
  )
  (setq lst (list l1 l2 l3 l4 l5 l6 l7 l8))
  (setq lst (vl-sort lst (function (lambda (a b) (<= (caar a) (caar b))))))
  (while (setq x   (car lst)
       out (cons x out)
       lst (cdr lst)
)
    (if (setq y (assoc (last x) lst))
      (setq lst (vl-remove y lst)
    lst (cons (cdr y) lst)
      )
    )
  )
  (apply 'append (reverse out))
)

Code: [Select]

Returns:
 ((0 0 0)
  (1 1 0)
  (1 2 1)
  (2 3 1)
  (2 2 1)
  (2 0 0)
  (3 4 5)
  (6 7 8)
  (9 10 11)
  (12 13 12)
  (14 15 12)
  (20 0 0)
  (21 1 0)
  (21 2 1)
  (22 3 1)
  (22 2 1)
  (22 0 0)
  (23 4 5)
  (26 7 8)
  (29 10 11)
  (32 13 12)
  (34 15 12)
 )

[David Bethel]

Ron

Thanks

I'm ring to get it figure out the start and stop values as well.

It should be simple. Maybe I'm over complicating it

[David Bethel]

hint: (assoc (last sublist) masterlist) ... <not @ a pc w/acad right now>

Not have any luck with this either
gr....

[gile]

Something like this ?

Code: [Select]

(defun combine (lst / foo bar)
  (defun foo (lst acc)
    (if lst
      (bar (car lst) (cdr lst) acc)
      acc
    )
  )
  (defun bar (l1 l2 acc / tmp)
    (cond
      ((setq tmp (assoc (last l1) l2))
(bar (append l1 (cdr tmp)) (vl-remove tmp l2) acc)
      )
      ((setq tmp (reverse (assoc (car l1) (mapcar 'reverse l2))))
(bar (append tmp (cdr l1)) (vl-remove tmp l2) acc)
      )
      (T (foo l2 (cons l1 acc)))
    )
  )
  (foo lst nil)
)

[ronjonp]

Here's my ugly version ... nice code Gile (as usual) 

Code: [Select]

(defun c:test (/ l1 l2 l3 l4 l5 l6 l7 l8 lst out result st x y)
  (setq l1 '((0 0 0) (1 1 0) (1 2 1) (2 3 1))
l2 '((22 3 1) (22 2 1) (22 0 0) (23 4 5))
l3 '((3 4 5) (6 7 8) (9 10 11))
l4 '((20 0 0) (21 1 0) (21 2 1) (22 3 1))
l5 '((2 3 1) (2 2 1) (2 0 0) (3 4 5))
l6 '((9 10 11) (12 13 12) (14 15 12))
l7 '((23 4 5) (26 7 8) (29 10 11))
l8 '((29 10 11) (32 13 12) (34 15 12))
  )
  (setq lst (vl-sort (list l1 l2 l3 l4 l5 l6 l7 l8) (function (lambda (a b) (<= (caar a) (caar b)))))
st  (vl-remove-if '(lambda (x) (assoc (car x) (mapcar 'reverse lst))) lst)
  )
  (repeat (length st)
    (while (and (setq x (car lst)) (not (equal x (cadr st))))
      (setq out (cons x out))
      (setq lst (cdr lst))
      (if (setq y (assoc (last x) lst))
(setq lst (vl-remove y lst)
      lst (cons (cdr y) lst)
)
      )
    )
    (setq result (cons (apply 'append (reverse out)) result))
    (setq out nil)
    (setq st (cdr st))
  )
  (reverse result)
)

[David Bethel]

Giles and Lee are both return 8 lines ( where I thought there was only 1)  I will need the rebuild my test bed.

The purpose is join multiple 3DPOLYs that have concurrent end points with a single call.  Currently I have to pick 2 adjoining entities over and over.

Thanks!  -David

[Lee Mac]

Perhaps its a problem with the rounding of Doubles, might need to add some tolerance.

Is Visual LISP allowed David?

[Lee Mac]

Something like this ?

Looks like you followed the same route as me, but your code is prettier 

[Lee Mac]

Here is perhaps a more concise version of my code, after learning from Gile's example - I still like his better though 

Code: [Select]

(defun PointGroup ( l / _remove _iterate )

  (defun _remove ( x l )
    (if l
      (if (equal (car l) x) (cdr l)
        (cons (car l) (_remove x (cdr l)))
      )
    )
  )

  (defun _iterate ( l / a )
    (cond
      ( (setq a (assoc (last (car l)) (cdr l)))

        (_iterate (cons (append (car l) (cdr a)) (_remove a (cdr l))))
      )
      ( (setq a (reverse (assoc (caar l) (mapcar 'reverse l))))

        (_iterate (cons (append (cdr a) (car l)) (_remove a (cdr l))))
      )
      ( (cons (car l) (PointGroup (cdr l))) )
    )
  )
  (if l (_iterate l))
)

[gile]

This one seems to work with the list in reply #3.
It's needed to test 4 cases: start and end of a sublist with both start and end of the other ones.

Code: [Select]

(defun combine (lst / foo bar)

  (defun foo (lst acc)
    (if lst
      (bar (car lst) (cdr lst) acc)
      acc
    )
  )

  (defun bar (new lst acc / start end tmp)
    (setq start (car new)
  end (last new)
    )
    (cond
      ((setq tmp (assoc start lst))
       (bar (append (reverse tmp) (cdr new)) (vl-remove tmp lst) acc)
       )
      ((setq tmp (assoc end lst))
(bar (append new (cdr tmp)) (vl-remove tmp lst) acc)
      )
      ((setq tmp (assoc start (setq lst (mapcar 'reverse lst))))
(bar (append (reverse tmp) (cdr new)) (vl-remove tmp lst) acc)
      )
      ((setq tmp (assoc end lst))
(bar (append new (cdr tmp)) (vl-remove tmp lst) acc)
      )
      (T (foo lst (cons new acc)))
    )
  )

  (foo lst nil)
)

[Lee Mac]

   Gile beat me to it again   

Code: [Select]

(defun PointGroup ( l / _remove _iterate )

  (defun _remove ( x l )
    (if l
      (if (equal (car l) x) (cdr l)
        (cons (car l) (_remove x (cdr l)))
      )
    )
  )

  (defun _iterate ( x l / a x1 x2 ) (setq x1 (car x) x2 (last x))
    (cond
      ( (setq a (assoc x1 l))
        (_iterate (append (reverse a) (cdr x)) (_remove a l))
      )
      ( (setq a (reverse (assoc x1 (mapcar 'reverse l))))
        (_iterate (append a (cdr x)) (_remove a l))
      )
      ( (setq a (assoc x2 l))
        (_iterate (append x (cdr a)) (_remove a l))
      )
      ( (setq a (assoc x2 (mapcar 'reverse l)))
        (_iterate (append x (cdr a)) (_remove (reverse a) l))
      )
      ( (cons x (PointGroup l)) )
    )
  )
  (if l (_iterate (car l) (cdr l)))
)
Updated to make better use of variables, but its pretty much like Gile's now... I wasn't sure whether David could use Visual LISP so opted for a Vanilla AutoLISP solution instead.