determine END and Start Item in chain list

Greetings everyone ...

iam working in some cad project and i have a master list contains sublislists look like something like this

(

(B1 B2)

(B2 B3)

(B3 B4)

(B5 B6)

(B6 B7)

(B8 B9)

)

HOW TO get the result that (B1,B4) and (B5,B9) are connceted together thougth a chain

Note : this master list may not be sorted as above

thanks for reading and best regards

well i write a lisp that worked fine for me ... i think it's written in bad lisp language but it works any way ...

and here it 's if anyone need it

;;;; created by Handasa 
(defun c:linea ( / sel b1 b2 a n sx enl ep ib il itml  p1 p2 pb ppa ppl ppv ssa ssb ssl
 bname1 bname2 counter dpx entb iblock ir itmb linelist obj all blist check dpx1 dpx2 ends entb1 entb2 found iz tval1 unique)
 
(vl-load-com)

(myblockcounter) ;;; get list of names selected blocks 
(ssbo) ;;; get selection of all selected blocks ssb in the drawing
(sso) ;;; prompt the user to select the line/polyline that connect blocks selected in the previous step
(setq ssa (ss_union2 ssl ssb)) ;;; merge the blocks and lines selection set
(command "_.ISOLATEOBJECTS" ssa "") ;;; isolate lines and blocks

(ZmObj ssa)

(setq ep '())
(setq all '())


(setq il 0)
(repeat (sslength ssl)
(setq ppl (list))


(setq itml (ssname ssl il))
(setq enl (entget itml)) 
(setq obj (cdr (assoc 0 enl)))

(if (= obj "LINE")
(progn
;(alert "line")
(setq p1 (cdr (assoc 10 enl)))
(setq p2 (cdr (assoc 11 enl)))
(setq ppl (list p1 p2))
;(setq polist ppl)
)
)

(if (or (= obj "POLYLINE")(= obj "LWPOLYLINE"))
(progn
;(alert "pline")
(foreach n enl
 (progn
  (setq ppa (car n))
  (setq ppv (cdr n))
  (if (= ppa 10) (setq ppl (append ppl (list ppv))))
)
);end n
)
)


(setq blist (LM:Unique blist))

(setq ib 0)
(setq linelist (list itml))

(repeat (length blist)
(setq pb (nth ib blist))
(setq b1 (cons 2 pb))

(setq a (ssget "F" ppl (list b1)))

(if (and a (ssname a 0)) (progn (setq linelist (append (list (ssname a 0)) linelist))))
(if (and a (ssname a 1)) (progn (setq linelist (append (list (ssname a 1)) linelist))))

(setq ib (1+ ib))
);;;; repeat blocks names

(setq all (cons linelist all))


;(setq ep (cons ppl ep))
(setq il (1+ il))
)



;;;;;;;; defining end blocks in general
(setq unique '())
(setq iblock 0)
(repeat (sslength ssb)
(setq itmb (ssname ssb iblock))
(setq entb (entget itmb))
(setq dPx (cdr (assoc 10 entb)))


(setq counter 0)
(setq ir 0)
(repeat (length all) 
(setq bname1 (nth 0 (nth ir all)))
(setq bname2 (nth 1 (nth ir all)))

(if (or (eq bname1 itmb)(eq bname2 itmb))
(progn
(setq counter (1+ counter))
)
)


(setq ir (1+ ir))
);repeat all list

;(if (= counter 1) (progn (setq unique (append (list itmb) unique))(circle dPx 1))) 
(if (= counter 1) (progn (setq unique (append (list itmb) unique)))) 


(setq iblock (1+ iblock))
); repeat ssb






;;; finding the end and strat of each circuit
(setq iz 0)
(setq ends '())
(repeat (length unique) ;;;;;;;;;;;;;;;;;;
(setq pb (nth iz unique))

(if (not (member pb ends))
(progn
(setq ends (append (list pb) ends))

(setq entb1 (entget pb))
(setq dPx1 (cdr (assoc 10 entb1)))

(setq check '())


(setq found 1)
(while (= found 1) ;;;;;;;;;;;;;;;;;;
(setq found 0)


(setq ir 0)
(repeat (length all) ;;;;;;;;;;;;;;;;;;
(setq bname1 (nth 0 (nth ir all)))
(setq bname2 (nth 1 (nth ir all)))

(if (and (eq bname1 pb)(not (member ir check)))
(progn
(setq pb bname2)
(setq found 1)
(setq check (append (list ir) check))
)
)


(if (and (eq bname2 pb)(not (member ir check)))
(progn
(setq pb bname1)
(setq found 1)
(setq check (append (list ir) check))
)
)
(setq ir (1+ ir))
);repeat all list




);end of while

(setq ends (append (list pb) ends))
(setq entb2 (entget pb))
(setq dPx2 (cdr (assoc 10 entb2)))

(circle dPx1 1)
(circle dPx2 1)

(setq tval1 (strcat "Circuit:" (rtos (1+ iz) 2 0)))

(ptext tval1 dPx1 )
(ptext tval1 dPx2 )

)
)
(setq iz (1+ iz))

);repeat unique list












; (setq test (ssadd))
; (setq ir 0)
; (repeat (length all) 
; (setq bname1 (nth 0 (nth ir all)))
; (setq bname2 (nth 1 (nth ir all)))

; (ssadd bname1 test)
; (ssadd bname2 test)

; (setq ir (1+ ir))
; );repeat all list

; (sssetfirst nil test)

(command "_.UNISOLATEOBJECTS")

);defun




;return similar lines / polylines selection set "ssl"
;;;;;; created by Stefan BMR

(defun SSo (  /  i e l f JF s1 sel)
(SETQ JF (getvar 'PICKSTYLE))
(setvar "PICKSTYLE" 0)

(setq s1 (ssadd))

(while (not sel)
(setq sel (car (entsel "\nSelect Circuit Line: ")))
)

(ssadd sel s1)

     (repeat (setq i (sslength s1))
       (setq i (1- i)
             e (entget (ssname s1 i))
             l (mapcar '(lambda (a b) (cond ((assoc a e)) (b))) '(0 8 6 62) '(0 0 (6 . "ByLayer") (62 . 256)))
             )
       (if (not (member l f)) (setq f (cons l f)))
       )
     (setq f (mapcar '(lambda (a) (append '((-4 . "<AND")) a '((-4 . "AND>")))) f))
     (setq f (append '((-4 . "<OR")) (apply 'append f) '((-4 . "OR>"))))
     (if (setq ssl (ssget "_X" f)) (princ (strcat (itoa (sslength ssl)) " objects")))
     ;(sssetfirst nil ssl)


 (setvar "PICKSTYLE" JF)
 (if (zerop (getvar 'cmdactive)) (princ) ssl)

 )
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

;;;;;;; get a list "blist" of all selected blocks
;;;;;; created by lee mac

 (defun myblockcounter ( /  idx ) ;; Define function, declare local variables
 (setq blist '())
   (if ;; If the following expression returns a non-nil value
       (setq sel ;; Assign the value returned by the following expression to the symbol 'sel'
           (ssget ;; Prompt the user to make a selection and return the selection set if successful
              '((0 . "INSERT")) ;; Filter the selection to block references only (INSERTs)
           ) ;; end ssget
       ) ;; end setq
       (repeat ;; Repeat the enclosed expressions the following number of times:
           (setq idx ;; Assign the value returned by the following expression to the symbol 'idx'
               (sslength sel) ;; Return the number of items in the selection set
           ) ;; end setq
           (setq blk ;; Assign the block name to the variable 'blk'
               (cdr ;; Retrieve the value associated with DXF group 2 (the block name)
                   (assoc 2 ;; Retrieve the DXF group 2 dotted pair from the following DXF data
                       (entget ;; Retrieve the list of DXF data for the following entity
                           (ssname sel ;; Retrieve the entity at the following index
                               (setq idx (1- idx)) ;; Decrement the index variable (since selection set indexes are zero-based)
                           ) ;; end ssname
                       ) ;; end entget
                   ) ;; end assoc
               ) ;; end cdr
           ) ;; end setq
       (setq blist (cons blk blist))
       ) ;; end repeat
   ) ;; end if

) ;; end defun




;;;;;; get selection set of all selected blocks in the drawing "ssb" 
;;;;;; created by Stefan BMR
(defun SSBo ( / i e l o n JF)
(SETQ JF (getvar 'PICKSTYLE))
(setvar "PICKSTYLE" 0) 


     (repeat (setq i (sslength sel))
       (setq o (vlax-ename->vla-object (ssname sel (setq i (1- i))))
             n (vlax-get o (if (vlax-property-available-p o 'EffectiveName) 'EffectiveName 'Name))
       )
       (if (not (member n l)) (setq l (cons n l)))
     )
    
     (if (setq ssb (ssget "_X" '((0 . "INSERT"))))
       (repeat (setq i (sslength ssb))
         (if
           (not
             (member
               (vlax-get
                 (setq o
                   (vlax-ename->vla-object
                     (setq e (ssname ssb (setq i (1- i))))
                   )
                 )
                 (if (vlax-property-available-p o 'EffectiveName)
                   'EffectiveName
                   'Name
                 )
               )
               l
             )
           )
           (ssdel e ssb)
           )
         )
       )
     (if ssb (princ (strcat (itoa (sslength ssb)) " objects")))
     ;(sssetfirst nil ssb)

   (setvar "PICKSTYLE" JF) 
 (if (zerop (getvar 'cmdactive)) (princ) ssb)
 )
 
 
 
 
(defun ss_union2 (ss1 ss2 / c)
(setq ssu (ssadd))

(setq c 0)
(repeat (sslength ss1)
(ssadd (ssname ss1 c) ssu)
(setq c (1+ c))
)

(setq c 0)
(repeat (sslength ss2)
(ssadd (ssname ss2 c) ssu)
(setq c (1+ c))
)

ssu
)
 
 
 
;;;; created by lee mac 
(defun LM:Unique ( l )
   (if l (cons (car l) (LM:Unique (vl-remove (car l) (cdr l)))))
)







;;;; created by lee mac 
 (defun Circle (cen rad)
 (entmakex (list (cons 0 "CIRCLE")
                 (cons 10 cen)
                 (cons 40 rad))))
                 
                 


;;;; created by lee mac 

(defun ZmObj  (ss / Minp Maxp lst)
 (vl-load-com)
 (foreach Obj (mapcar 'vlax-ename->vla-object
                (vl-remove-if 'listp
                  (mapcar 'cadr
                    (ssnamex ss))))
   (vla-getBoundingBox Obj 'Minp 'Maxp)
   (setq lst (cons
               (mapcar 'vlax-safearray->list
                 (list Minp Maxp)) lst)))
 (vla-ZoomWindow
   (vlax-get-acad-object)
     (vlax-3D-point
       (car (maxminpnt (mapcar 'car lst))))
       (vlax-3D-point
         (cadr (maxminpnt (mapcar 'cadr lst))))))
         
         
;;;; created by lee mac     
(defun ptext ( tval pp )

   (entmake (list '(0 . "TEXT")
              '(8 . "0") ; Change this for different Layer (type layer name in quote marks)
              (cons 10 pp)
              (cons 40 0.3) ; Change this for different height (set at default text size, change all red parts to just a number, i.e. (cons 40 2.5)
              (cons 1 tval)
              '(50 . 0.0)
              '(7 . "STANDARD") ; change this for different Text Style (type style name in quote marks)
              '(71 . 0)
              '(72 . 0)
              '(73 . 0)
        ) ;_  end list
   ) ;_  end entmake

Note: B5 and B9 are not connected in the example.

(setq lst
 '(
   (B1 B2)
   (B2 B3)
   (B3 B4)

   (B5 B6)
   (B6 B7)
   
   (B8 B9)
 )
)

; (CheckConnect lst 'b1 'b4)
(defun CheckConnect (lst sta end)
 (while
   (and
     (not (equal sta end))
     (setq sta (cadr (assoc sta lst)))
   )
 )
 (equal sta end)
)

EDIT:

The list may contain duplicate subs, but not 'mirrored' subs.

(setq lst
 '(
   (B1 B2)
   [color=red](B2 B1)[/color] ; Mirrored sub.
   (B2 B3)
   (B3 B4)

   (B5 B6)
   (B6 B7)
   
   (B8 B9)
 )
)

Note: B5 and B9 are not connected in the example.

(setq lst
 '(
   (B1 B2)
   (B2 B3)
   (B3 B4)

   (B5 B6)
   (B6 B7)
   
   (B8 B9)
 )
)

; (CheckConnect lst 'b1 'b4)
(defun CheckConnect (lst sta end)
 (while
   (and
     (not (equal sta end))
     (setq sta (cadr (assoc sta lst)))
   )
 )
 (equal sta end)
)

nice work ... this need further more to detect the end items of each chain .... first we need to check number of occurrence of each item in the list to detect end items in general i.e B1 , B4 , B5 , B9 .. each of them repeated only once in the list

so by making a list of them say "unique_list"

(setq unique_list (list "B1" "B4" "B5" B9"))

then using your code we will iterate through each item in the "unique_list" to check their connection with the other remaining items in the "unique_list"

.....

your code saved me many lines in my poor attempt to find the connection beween items ... thanks my friend

another question If you have time sir ...

how to lookup a value in list and find it's location in a list

does autolisp have a ready function to do that like excel

i.e if i have a list '(b1 b2 b3 b4)

how to detect that the list have a value of "b2" and it's the second item ??

thanks in advance

i.e if i have a list '(b1 b2 b3 b4)

how to detect that the list have a value of "b2" and it's the second item ??

A few functions: member, vl-position, nth

The list may contain duplicate subs, but not 'mirrored' subs

unfortunately the list may and does have mirrored subs ...

A few functions: member, vl-position, nth

thanks and i will check these functions

Maybe this helps:

(setq lst
 '(
   (B8 B9) ; Unconnected.
   (B1 B2)
   (B6 B5) ; Mirrored.
   (B2 B1) ; Mirrored duplicate.
   (B3 B4)
   (B2 B3)
   (B6 B7)
   (B10 B11) ; Unconnected.
 )
)

; (List_To_Chains lst) => ((B8 B9) (B1 B2 B3 B4) (B5 B6 B7) (B10 B11))
(defun List_To_Chains (lst / fnd len)
 (setq len 2147483647) ; Max. 32 bit integer as start value.
 (while (> len (setq len (length lst)))
   (foreach sub lst
     (cond
       ((setq fnd (assoc (cadr sub) lst))
         (if (equal (car sub) (cadr fnd))
           (setq lst (vl-remove sub lst))
           (setq lst (subst (cons (car sub) fnd) fnd (vl-remove sub lst)))
         )
       )
       ((setq fnd (assoc (car sub) (vl-remove sub lst)))
         (if (equal (cadr sub) (cadr fnd))
           (setq lst (vl-remove sub lst))
           (setq lst (subst (cons (cadr sub) fnd) fnd (vl-remove sub lst)))
         )
       )
     )
   )
 )
 lst
)

; (Find_In_Chains (List_To_Chains lst) 'B3) => (B1 B2 B3 B4)
(defun Find_In_Chains (chainLst itm)
 (vl-some
   '(lambda (sub) (if (vl-position itm sub) sub))
   chainLst
 )
)

EDIT: The code for List_To_Chains is faulty.

See: http://www.cadtutor.net/forum/showthread.php?101025-determine-END-and-Start-Item-in-chain-list&p=686700&viewfull=1#post686700

Maybe this helps:

(setq lst
 '(
   (B8 B9) ; Unconnected.
   (B1 B2)
   (B6 B5) ; Mirrored.
   (B2 B1) ; Mirrored duplicate.
   (B3 B4)
   (B2 B3)
   (B6 B7)
   (B10 B11) ; Unconnected.
 )
)

; (List_To_Chains lst) => ((B8 B9) (B1 B2 B3 B4) (B5 B6 B7) (B10 B11))
(defun List_To_Chains (lst / fnd len)
 (setq len 2147483647) ; Max. 32 bit integer as start value.
 (while (> len (setq len (length lst)))
   (foreach sub lst
     (cond
       ((setq fnd (assoc (cadr sub) lst))
         (if (equal (car sub) (cadr fnd))
           (setq lst (vl-remove sub lst))
           (setq lst (subst (cons (car sub) fnd) fnd (vl-remove sub lst)))
         )
       )
       ((setq fnd (assoc (car sub) (vl-remove sub lst)))
         (if (equal (cadr sub) (cadr fnd))
           (setq lst (vl-remove sub lst))
           (setq lst (subst (cons (cadr sub) fnd) fnd (vl-remove sub lst)))
         )
       )
     )
   )
 )
 lst
)

; (Find_In_Chains (List_To_Chains lst) 'B3) => (B1 B2 B3 B4)
(defun Find_In_Chains (chainLst itm)
 (vl-some
   '(lambda (sub) (if (vl-position itm sub) sub))
   chainLst
 )
)

Impressive .... thanks for your brilliant code and your time Sir

@Roy, since foreach caches the list argument when iterating over each element, you may encounter some odd results when processing elements which have already been modified in the main list, depending on the order in which they are encountered e.g.:

(setq ls1 '((B1 B2) (B3 B4) (B2 B3) (B1 B2)))
(setq ls2 '((B1 B2) (B1 B2) (B3 B4) (B2 B3)))

_$ (List_To_Chains ls1)
((B1 B2 B3))
_$ (List_To_Chains ls2)
((B1 B2 B3 B4))

Thanks for your comment Lee. You are right in that the function can give faulty results, but I don't think this is due to the use of foreach. But rather to the fact that when comparing values only the first two items of the subs are ever considered.

EDIT: Lee you are in fact correct, the use of foreach is problematic.

Improved but still not perfect* (and not very elegant):

(defun List_To_Chains (lst / doneLst fnd len)
 (setq len 2147483647) ; Max. 32 bit integer as start value.
 (while (> len (setq len (length lst)))
   (setq doneLst nil)
   (foreach sub lst
     (cond
       ((vl-position sub doneLst))
       ((not (setq doneLst (cons sub doneLst))))
       ((setq fnd (assoc (cadr sub) lst))
         (if (equal (car sub) (cadr fnd))
           (setq lst (vl-remove sub lst))
           (setq lst (subst (cons (car sub) fnd) fnd (vl-remove sub lst)))
         )
       )
       ((setq fnd (assoc (car sub) (vl-remove sub lst)))
         (if (equal (cadr sub) (cadr fnd))
           (setq lst (vl-remove sub lst))
           (setq lst (subst (cons (cadr sub) fnd) fnd (vl-remove sub lst)))
         )
       )
     )
   )
 )
 lst
)

*The code does not work properly in all cases. E.g.:

(setq ls3 '((B1 B2 B3 B4 B5) (B3 B4) (B2 B3) (B1 B2)))

Nice one Roy.

Here's my attempt:

(defun chain ( l / a r x )
   (while (setq x (car l))
       (setq l (vl-remove (reverse x) (vl-remove x l)))
       (while
           (cond
               (   (setq a (assoc (car x) l))
                   (setq x (append (reverse a) (cdr x))
                         l (vl-remove a l)
                   )
               )
               (   (setq a (assoc (last x) l))
                   (setq x (append x (cdr a))
                         l (vl-remove a l)
                   )
               )
               (   (setq a (assoc (car x) (mapcar 'reverse l)))
                   (setq x (append (reverse a) (cdr x))
                         l (vl-remove a l)
                   )
               )
               (   (setq a (assoc (last x) (mapcar 'reverse l)))
                   (setq x (append x (cdr a))
                         l (vl-remove a l)
                   )
               )
           )
       )
       (setq r (cons x r))
   )
   (reverse r)
)

Nice one Roy.

 

Here's my attempt:

(defun chain ( l / a r x )
   (while (setq x (car l))
       (setq l (vl-remove (reverse x) (vl-remove x l)))
       (while
           (cond
               (   (setq a (assoc (car x) l))
                   (setq x (append (reverse a) (cdr x))
                         l (vl-remove a l)
                   )
               )
               (   (setq a (assoc (last x) l))
                   (setq x (append x (cdr a))
                         l (vl-remove a l)
                   )
               )
               (   (setq a (assoc (car x) (mapcar 'reverse l)))
                   (setq x (append (reverse a) (cdr x))
                         l (vl-remove a l)
                   )
               )
               (   (setq a (assoc (last x) (mapcar 'reverse l)))
                   (setq x (append x (cdr a))
                         l (vl-remove a l)
                   )
               )
           )
       )
       (setq r (cons x r))
   )
   (reverse r)
)

for a given chain list l

(setq l

'(

(BAR1 TTEJ)

(NUXD TTEJ)

(DNZC NUXD)

(EUOL DNZC)

(VXVD EUOL)

(RKSG VXVD)

(WYHC RKSG)

(OTNT WYHC)

(XXET OTNT)

(EDME XXET)

(VUWR EDME)

(VUWR BFCX)

(BFCX NMNU)

(NMNU MHBH)

(MHBH RKAG)

(OGCR RKAG)

(VSYL OGCR)

(UEIC VSYL)

(QCCS UEIC)

(WXJR QCCS)

(DJFL WXJR)

(AYVR DJFL)

(JMXB AYVR)

(EXPD JMXB)

(JWNQ EXPD)

(NYPW JWNQ)

(FSWM NYPW)

(FSWM ZZVF)

(ZZVF WNGN)

(WNGN JZCL)

(JZCL CIGE)

(CIGE ENZY)

(ENZY QLUJ)

(QLUJ HGKE)

(HGKE VPYE)

(VPYE AUTU)

(AUTU UFZL)

(UFZL IQHM)

(IQHM ANIF)

(ANIF LEMC)

(LEMC SJGN)

(SJGN PUZJ)

(PUZJ GBFR)

(GBFR BJCI)

(BJCI KWFC)

(KWFC JBIS)

(JBIS UTLF)

(UTLF LSHS)

(LSHS YTZP)

(YTZP KOSO)

(KOSO HSDX)

(HSDX FACX)

(FACX IHCA)

(IHCA KCVE)

(KCVE FGMH)

(FGMH OEGU)

(OEGU QYQZ)

(QYQZ QIXX)

(QIXX GPYQ)

(GPYQ MIBM)

(MIBM EZRR)

(EZRR REME)

(REME CVPC)

(CVPC RBVL)

(RBVL EYVF)

(EYVF FVWE)

(FVWE OREG)

(OREG XRBE)

(XRBE LVSL)

(LVSL SOBH)

(SOBH HUWB)

(HUWB ULYX)

(ULYX CJFA)

)

)

the result will be as follow with repeated items in Red and discrete sublists while they are chained

((BAR1 TTEJ NUXD TTEJ) (DNZC EUOL DNZC NUXD) (VXVD RKSG VXVD EUOL) (WYHC OTNT WYHC RKSG) (XXET EDME XXET OTNT)

(RKAG OGCR RKAG MHBH NMNU BFCX VUWR EDME) .....

Sorry, I forgot to redefine the list after the reverse expressions - my brief testing didn't highlight this.

(defun chain ( l / a r x )
   (while (setq x (car l))
       (setq l (vl-remove (reverse x) (vl-remove x l)))
       (while
           (cond
               (   (setq a (assoc (car x) l))
                   (setq x (append (reverse a) (cdr x))
                         l (vl-remove a l)
                   )
               )
               (   (setq a (assoc (last x) l))
                   (setq x (append x (cdr a))
                         l (vl-remove a l)
                   )
               )
               (   (setq a (assoc (car x) (setq l (mapcar 'reverse l))))
                   (setq x (append (reverse a) (cdr x))
                         l (vl-remove a l)
                   )
               )
               (   (setq a (assoc (last x) l))
                   (setq x (append x (cdr a))
                         l (vl-remove a l)
                   )
               )
           )
       )
       (setq r (cons x r))
   )
   (reverse r)
)

Sorry, I forgot to redefine the list after the reverse expressions - my brief testing didn't highlight this.

it's working like a charm now ... a very great job Mr.lee

Lee , You are Genius .... god bless You

Thank you handasa

Solution using vl-some:

(defun List_To_Chains (lst)
 (while
   (vl-some
     '(lambda (sub / fnd)
       (cond
         ((setq fnd (assoc (last sub) lst))
           (if (equal (cadr (reverse sub)) (cadr fnd))
             (setq lst (vl-remove (if (<= (length sub) (length fnd)) sub fnd) lst))
             (setq lst (subst (append sub (cdr fnd)) fnd (vl-remove sub lst)))
           )
         )
         ((setq fnd (assoc (car sub) (vl-remove sub lst)))
           (if (equal (cadr sub) (cadr fnd))
             (setq lst (vl-remove (if (<= (length sub) (length fnd)) sub fnd) lst))
             (setq lst (subst (append (reverse (cdr sub)) fnd) fnd (vl-remove sub lst)))
           )
         )
       )
     )
     lst
   )
 )
 lst
)

BTW: Both my last suggestion and Lee's Chain do not work on:

(setq ls3 '((B1 B2 B3 B4 B5) (B3 B4) (B2 B3) (B1 B2)))

: (chain ls3)
((B4 B3 B2 B1 B2 B3 B4 B5))
: (List_To_Chains ls3)
((B1 B2 B3 B4 B5) (B2 B3 B4))