topic Re: Sort help in Visual LISP, AutoLISP and General Customization Forum

Sort help

zph — Mon, 11 Jul 2016 14:58:23 GMT

Good day!

I'd like to be able to sort a list of points ascending by there X coordinate and if the X coordinates are the same, sort those points descending by there Y coordinates.

I looked around and found the X coordinate sorting and tailored it:

(setq eList (vl-sort (append i3List i4List)
	(function (lambda (x y) (< 
		(cadr (assoc 10 (entget (car x)))) 
		(cadr (assoc 10 (entget (car y))))	))))) ;sorts by X coordinate

The red code... "(car x)" and "(car y)" are enames.

I'm not sure of how to implement an IF statement when the X coordinates match, inside the vl-sort function.

Help, please.

Re: Sort help

ВeekeeCZ — Mon, 11 Jul 2016 15:34:00 GMT

Here is a quick test function. Sort it by y-coord first, then x-coord.

(defun c:test ( / ss lst i )

  (setq ss (ssget))
  
  (repeat (setq i (sslength ss))
    (setq lst (cons (ssname ss (setq i (1- i))) lst)))

  (setq lst (vl-sort lst (function (lambda (x y) (< (caddr (assoc 10 (entget x)))
						    (caddr (assoc 10 (entget y)))))))
	lst (vl-sort lst (function (lambda (x y) (< (cadr (assoc 10 (entget x)))
						    (cadr (assoc 10 (entget y))))))))

  (command "pline")
  (foreach e lst (command "_none" (cdr (assoc 10 (entget e)))))
  (command)	   
    
  (princ)
)

Re: Sort help

zph — Mon, 11 Jul 2016 15:46:03 GMT

Thanks for the quick reply, BCZ.

However, this isn't quite what I need. I only want to sort points by their Y components IF their X components are identical.

Basically, I need a tie-breaker between points that are aligned and I'd prefer to sort THESE points only by their Y location.

Does this make sense?

Re: Sort help

zph — Mon, 11 Jul 2016 15:54:19 GMT

I've attached a visual.

I want the order of the points in the list to mimic how the points are numbered.

P1 is first, followed by P2, P3, P4, and P5.

You'll notice how P2, P3, and P4 are aligned vertically and I want point on top (P2) to be listed before the points below it.

So, left to right and (if needed) top to bottom.

Re: Sort help

marko_ribar — Mon, 11 Jul 2016 17:20:12 GMT

According to your posted picture...

(defun c:sort-texts ( / ss l k )
  (prompt "\nSelect text entities labeled with only single letter \"p\" which are positioned according to sorting rules...")
  (setq ss (ssget "_:L" '((0 . "TEXT"))))
  (setq l (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
  (setq l (vl-sort l '(lambda ( a b ) (if (equal (car (cdr (assoc 10 (entget a)))) (car (cdr (assoc 10 (entget b)))) 1e-6)
                                        (> (cadr (cdr (assoc 10 (entget a)))) (cadr (cdr (assoc 10 (entget b)))))
                                        (< (car (cdr (assoc 10 (entget a)))) (car (cdr (assoc 10 (entget b)))))
                                      )
                      )
          )
  )
  (setq k 0)
  (foreach e l
    (entupd (cdr (assoc -1 (entmod (subst (cons 1 (strcat (cdr (assoc 1 (entget e))) (itoa (setq k (1+ k))))) (assoc 1 (entget e)) (entget e))))))
  )
  (princ)
)

HTH

Re: Sort help

Kent1Cooper — Mon, 11 Jul 2016 18:06:17 GMT

@zph wrote:

....

I'd like to be able to sort a list of points ascending by there X coordinate and if the X coordinates are the same, sort those points descending by there Y coordinates.

....

You could modify code from BlockSSSort.lsp, available here. It stands for Block Selection Set Sort, and it's made to sort a selection set of Blocks into a list ordered by insertion-point positions in both directions, but you can alter it to take a list of points as input. It sorts by one coordinate comparison, and wherever that coordinate is the same for more than one of them, it keeps those in a separate sublist, which it then sorts by comparison in the other direction. Its arguments specify which edge to start with, and in which direction to sort within each aligned sublist. For the directions you describe, with Blocks the usage would be (BSSS "L" "T"), that is, sort starting on the Left side, sorting any multiples that align [in the X direction in that case] from the Top down.

You will need to tailor it to exactly what your input is -- it takes a User object(s) selection, but it seems from your description that you are starting with a list of point-coordinate lists, which is one alteration to BlockSSSort, and it would be an easy adjustment to use User on-screen point picks instead.

Re: Sort help

scot-65 — Mon, 11 Jul 2016 22:21:50 GMT

>> So, left to right and (if needed) top to bottom.

You might need to position your points in the
Fourth Quadrant for it to work LtoR and TtoB...

???

Re: Sort help

joselggalan — Tue, 12 Jul 2016 09:20:05 GMT

try this:
dwg attachment with test points:

Code of (test1):

(defun test1 ( / MiList get10)
  (setq	MiList
	 '(("P1" (2081.59 936.449 0.0))
	   ("P3" (2088.04 940.865 0.0))
	   ("P5" (2094.3 939.376 0.0))
	   ("P8" (2101.77 940.865 0.0))
	   ("P4" (2088.04 936.42 0.0))
	   ("P2" (2088.04 943.495 0.0))
	   ("P6" (2094.3 936.477 0.0))
	   ("P9" (2099.8 936.614 0.0))
	   ("P7" (2099.8 944.333 0.0))
	  )
  )
  (setq L1 (vl-sort
	   MiList
	   (function
	     (lambda (e1 e2)
	       (or
		(< (caadr e1) (caadr e2)) ;; < X X'
		(and
		 (equal (caadr e1) (caadr e2)) ;; equal X X'
		 (> (cadadr e1) (cadadr e2))   ;; > Y Y'
		)
	       )
	     )
	    )
	  )
  )
)

Result:

(("P1" (2081.59 936.449 0.0))
  ("P2" (2088.04 943.495 0.0))
  ("P3" (2088.04 940.865 0.0))
  ("P4" (2088.04 936.42 0.0))
  ("P5" (2094.3 939.376 0.0))
  ("P6" (2094.3 936.477 0.0))
  ("P7" (2099.8 944.333 0.0))
  ("P9" (2099.8 936.614 0.0))
  ("P8" (2101.77 940.865 0.0))
)

regards..

Re: Sort help

zph — Tue, 12 Jul 2016 18:28:24 GMT

It's all in the details. Thank you Marko, Kent, Scott, and Jose for your replies.

However, until I realized that I needed to be using ASSOC 11 rather than 10, all my attempts had been in vain. Assoc 10, the insertion point on a text entity, changes based upon text length (the actual length...not character length). Assoc 11, the corresponding justification point, stays the same regardless of text length.

Thank you for showing me how to incorporate more complicated comparisons into the vl-sort function.

Re: Sort help

ВeekeeCZ — Tue, 12 Jul 2016 18:54:57 GMT

@zph wrote:
...
However, until I realized that I needed to be using ASSOC 11 rather than 10, all my attempts had been in vain. Assoc 10, the insertion point on a text entity, changes based upon text length (the actual length...not character length). Assoc 11, the corresponding justification point, stays the same regardless of text length.
...

zph, FYI if you have a default text alignment, then (cdr (assoc 11 (entget (car (entsel))))) returns '(0 0 0)! Try any text in Marco's test file.

Simple condition could be that if 11 code equals to '(0 0 0), then take code 10. But there is a small probability that 11 is actually '(0 0 0) on purpose.

More reliable is that if both codes 72 and 73 are 0, then take code 10.

Re: Sort help

Kent1Cooper — Tue, 12 Jul 2016 18:58:28 GMT

@zph wrote:
.... Assoc 10, the insertion point on a text entity, changes based upon text length (the actual length...not character length). Assoc 11, the corresponding justification point, stays the same regardless of text length.
....

It's actually a little more convoluted than that. Assoc 10 is always the left end of the baseline of the Text object. If it's ordinary Left-justified, that is also the insertion point [to which Osnap INS will snap], and Assoc 11 is always 0,0,0, regardless of position in the drawing, so using the 11 value can lead you astray. If the justification is anything other than Left, Assoc 10 is still the left end of the baseline, and Assoc 11 is the insertion point.

So to be sure you get what you want, no matter what the Text's justification, you might want to extract insertion points with a test -- if both Assoc 72 and Assoc 73 values are 0, it's Left-justified, and its insertion point is Assoc 10, but if either of those is not zero [except see the next paragraph], it's some other justification and its insertion point is Assoc 11.

BUT it's even more complicated if you ever use Fit or Aligned justifications. 10 is the left end of the baseline, 11 the right end, and you would need to choose one, or maybe use the point halfway in between. For Fit, the Assoc 72 value is 5 and 73 is 0; for Aligned, 72 is 3 and 73 is 0. You could also check justification via VLA properties instead of with a check on two different Assoc values.

Re: Sort help

zph — Tue, 12 Jul 2016 19:03:51 GMT

Well, thank you for clearing that up, Kent.

I am impressed. 😉

Cheers!

Re: Sort help

zph — Tue, 12 Jul 2016 19:37:06 GMT

Thank you for the recommendation, BCZ.

I'll put this on the LISP list of things to do...the next order is work my spanking new 'ordered-by-location' list into the an already established routine.

Should be fun 🙂

Re: Sort help

zph — Thu, 26 Jan 2017 14:36:47 GMT

Wow, it has been a while. It seems I've run into an error with the overall routine incorporating this sorting function.

Please, take a look at the attached .dwg file too see the problem, the noted issue, and the desired result.

I am fairly certain that the error lies somewhere in the sorting function which is why I am posting back here.

It is worth noting that this error does NOT occur all the time. For some reason, it is occurring with this selection set.

The routine:

(defun c:cable_renum ( / adoc eFlag aList bList fD *error* ssBubs i8List cList cList2
			wP1 wP2 iList cTvLc tList eList i3List i4List i5List i6List i7List tVal iClist tCt tNum)

(vl-load-com)
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(setvar "cmdecho" 0)
(setq eFlag 1 ssBubs (ssadd)
	aList (list 	"A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" 
			"N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z")
	bList (list 	"LMR" ))

;***************;
(setq fD 1.25)	; fuzz distance for text alignment in cableRenum_sortList
;***************;

(defun *error* (msg)
	(if (member msg '("quit / exit abort" "Conversion failed." "*Cancel*"))
		(progn (setvar "cmdecho" 1)(vla-endundomark adoc)
			(cond
				((= eFlag 1) (princ "\n <!> Routine aborted <!> "))
				((= eFlag 2) (princ "\n <!> Cable values adjusted <!> "))
			) ;cond
		) ;progn
	) ;if
) ;*error*

(cableRenum_getReady)
(cableRenum_getAllCables wP1 wP2)
(cableRenum_idBUBREFs wP1 wP2)
(cableRenum_consolidate)
(cableRenum_parse)

(if (> (sslength ssBubs) 0) (command "chprop" ssBubs "" "c" "1" ""))
(setq eFlag 2)
(exit)
) ;cable_renum


;;;;;-----=====     subFunction:  cableRenum_getReady     =====-----;;;;;


(defun cableRenum_getReady ()

(if 	(not 	(and 	(princ "\n\033\n Select two points for crossing window ")
			(setq wP1 (getpoint "\n <.> Select 1st point "))
			(setq wP2 (getpoint "\n <.> Select 2nd point "))
		) ;and
	) ;not

	(progn (princ "\n Two points required ")(exit))
	(progn (command "zoom" "w" wP1 wP2)(alert " Please, wait while routine completes\n\n\n...click OK to continue "))
) ;if

) ;cableRenum_getReady


;;;;;-----=====     subFunction:  cableRenum_getAllCables     =====-----;;;;;


(defun cableRenum_getAllCables (wP1 wP2 / allC tCntr aFlag tName tVal tLen tempL)

(if (setq allC (ssget "_C" wP1 wP2 '((0 . "TEXT")(8 . "TEXT")(67 . 0))) tCntr 0)
	(while (< tCntr (sslength allC))
	(setq aFlag "T" tName (ssname allC tCntr) tVal (cdr (assoc 1 (entget tName))) tLen (strlen tVal))	

		(if (>= tLen 3)
			(progn
			(setq tempL (mapcar 'chr (vl-string->list (substr tVal (- tLen 2)))))
			(foreach l tempL (if (member l aList) (setq aFlag "F")))
			(if (member (substr tVal 1 3) bList) (setq aFlag "F"))
			) ;progn
		) ;if

		(if	(and	(= aFlag "T")
				(> tLen 10)
				(wcmatch (substr tVal (- tLen 3) 1) "-")
				(wcmatch (substr tVal (- tLen 7) 1) "-")
				(= (vl-string-search "," tVal) nil)
				(= (vl-string-search " " tVal) nil)
			) ;and	

		(setq iList (append iList (list tName)))
		) ;if

	(setq tCntr (1+ tCntr))
	) ;while

	(progn (princ "\n\033\n < Selection set empty > ")(exit))
) ;if

) ;cableRenum_getAllCables


;;;;;-----=====     subFunction:  cableRenum_idBUBREFs     =====-----;;;;;


(defun cableRenum_idBUBREFs (wP1 wP2 / ssC ssV cList vList vFlag cntrC cntrV cIpnt pt1 pt2 lpt1 lpt2 
				bFind lFind sPnt ePnt tFind)

(if (setq vFlag 0 cntrC 0 cntrV 0 ssC (ssget "_C" wP1 wP2 '((0 . "CIRCLE")(8 . "TEXT")(40 . 0.25))))
	(progn
	(setq ssV (ssget "X" '((0 . "LWPOLYLINE")(8 . "0,VIEWPORT")(67 . 0))))
	(while (< cntrC (sslength ssC)) (setq cList (cons (ssname ssC cntrC) cList) cntrC (1+ cntrC)))
	(while (< cntrV (sslength ssV)) (setq vList (cons (ssname ssV cntrV) vList) cntrV (1+ cntrV)))
	(if (= (getvar "tilemode") 0) (setvar "tilemode" 1))

		(foreach c cList
			(progn
			(setq vFlag 0 cIpnt (cdr (assoc 10 (entget c))))
			(vla-getboundingbox (vlax-ename->vla-object c) 'pt1 'pt2)
			(setq 	pt1 (vlax-safearray->list pt1) pt2 (vlax-safearray->list pt2)
				lpt1 (list (- (car pt1) 0.025) (- (cadr pt1) 0.025))
				lpt2 (list (+ (car pt2) 0.025) (+ (cadr pt2) 0.025)))	

				(if (setq bFind (ssget "X" (list	
					'(0 . "TEXT")'(8 . "TEXT")'(67 . 0)
					'(-4 . "<AND")
					'(-4 . ">,>,=") (cons 10 (list (car pt1) (cadr pt1)))
					'(-4 . "<,<,=") (cons 10 (list (car pt2) (cadr pt2)))
					'(-4 . "AND>"))))

(foreach v vList
	(if (= vFlag 0)
		(progn
		(vla-getboundingbox (vlax-ename->vla-object v) 'pt1 'pt2)
		(setq pt1 (vlax-safearray->list pt1) pt2 (vlax-safearray->list pt2))

			(if	(and	(>= (car cIpnt) (car pt1))(>= (cadr cIpnt) (cadr pt1))
					(<= (car cIpnt) (car pt2))(<= (cadr cIpnt) (cadr pt2)))
							
(if (setq lFind (ssget "_C" lpt1 lpt2 '((0 . "LINE")(8 . "WIRE")(67 . 0))))

	(if	(setq	sPnt (cdr (assoc 10 (entget (ssname lFind 0))))
			ePnt (cdr (assoc 11 (entget (ssname lFind 0))))
			tFind (ssget "_W" sPnt (list (car ePnt) (+ (cadr ePnt) 0.25)) 
				'((0 . "TEXT")(8 . "TEXT")(67 . 0))))
	
		(setq vFlag 1 cTvLc (cons (list
			c 
			(ssname bFind 0)
			(cdr (assoc 1 (entget (ssname bFind 0))))
			v 	
			(ssname lFind 0) 
			(ssname tFind 0)
			(cdr (assoc 1 (entget (ssname tFind 0))))) cTvLc))
	) ;if
) ;if
			) ;if
		) ;progn
	) ;if
) ;foreach
				) ;if
			) ;progn
		) ;foreach
	) ;progn
) ;if

) ;cableRenum_idBUBREFs


;;;;;-----=====     subFunction:  cableRenum_consolidate     =====-----;;;;;


(defun cableRenum_consolidate ( / zList rFlag cVal)

(foreach c cTvLc (setq zList (cons (list (nth 5 c) (nth 1 c)) zList)))

(foreach iL iList
	(progn
	(setq rFlag "F" cVal (cdr (assoc 1 (entget iL))))
	(foreach z zList (if (equal iL (car z)) (setq rFlag "T")))
	(if (= rFlag "F") (setq i3List (cons (list iL) i3List)))

		(if (= (member (list (substr cVal 1 (- (strlen cVal) 3))) tList) nil)
		(setq tList (cons (list (substr cVal 1 (- (strlen cVal) 3))) tList))
		) ;if
	) ;progn
) ;foreach

(foreach i3 i3List (progn (princ "\n i3List:  ")(princ i3)(princ "   ")(princ (cdr (assoc 1 (entget (car i3)))))))

(foreach z zList 
	(setq 	i4List (cons (list 
				(nth 0 z)
				(cdr (assoc 1 (entget (nth 0 z))))
				(cdr (assoc 1 (entget (nth 1 z))))) i4List)
		i7List (cons (cdr (assoc 1 (entget (nth 1 z)))) i7List)
	) ;setq
) ;foreach

(setq 	i7List (cableRenum_Count i7List)
	eList (append i3List i4List)
 	tList (vl-sort tList '(lambda (x y) (< (car x) (car y)))))

) ;cableRenum_consolidate


;;;;;-----=====     subFunction:  cableRenum_parse     =====-----;;;;;


(defun cableRenum_parse ( / tCt sCntr sCntr3 tRlist tSlist tTlist tUlist tVlist tUlen i7len i8List tUl itQA sCntr2)

(foreach t1 tList			
	(progn
	(setq sCntr 0 tSlist () i5List () tRlist () i8List ())
		(foreach e1 eList
			(if	(and	(not (= eList nil))
					(not (= e1 nil))
					(equal  
						(substr 
							(cdr (assoc 1 (entget (car e1)))) 
							1 
							(- (strlen (cdr (assoc 1 (entget (car e1))))) 3)
						) ;substr
						(car t1)
					) ;equal
				) ;and

				(progn
				(cableRenum_PnI)
				(cableRenum_increase)
				) ;progn
			) ;if
		) ;foreach
	) ;progn
) ;foreach

) ;cableRenum_parse


;;;;;-----=====     subFunction:  cableRenum_PnI     =====-----;;;;;


(defun cableRenum_PnI ( / )

(if (= (member e1 i4List) nil)
	(setq i8List (cons e1 i8List))

	(progn
	(setq 	tTlist () tUlist () tVlist () 
		itQA 0
		sCntr3 0 
		i4List (vl-sort i4List '(lambda (x y) (< (caddr x) (caddr y)))))

		(while (< sCntr (length i4List))
			(foreach i7 i7List		; find QAs of BUBREFs
			(if (= (caddr (nth sCntr i4List)) (car i7)) (setq itQA (cdr i7)))
			) ;foreach

		(setq tRlist () sCntr2 0 titQA (+ itQA sCntr3))

			(while (< sCntr3 titQA)
			(setq 	tRlist (append tRlist (list (nth sCntr3 i4List)))
				sCntr3 (1+ sCntr3))
			) ;while

			(setq 	tSlist (cableRenum_sortList tRlist) 
				sCntr (+ sCntr itQA) 
				sCntr2 0
				tTlist (append tTlist (list tSlist))
			) ;setq

			(foreach tT tTlist
				(progn
				(setq tUlist ())
					(foreach ta tT
						(setq tUlist 
							(append tUlist 
								(list (car ta))
							) ;append
						) ;setq
					) ;foreach
				(setq tVlist (append tVlist (list tUlist)))
				) ;progn
			) ;foreach					
		) ;while

		(setq tSlist tTlist)

	(setq i7len (length i7List) tRlist ())

		(while (> i7len 0)
			(setq 	tRlist (cons (last tVlist) tRlist)
				tVlist (vl-remove (last tVlist) tVlist)
				i7len (1- i7len)
			) ;setq
		) ;while

		(foreach tS tSlist
			(if (or (= (length tS) 1)(> (length tS) 2))
			(foreach ta tS (setq ssBubs (ssadd (car ta) ssBubs)))
			) ;if
		) ;foreach

	(setq i5List tRlist)
	) ;progn
) ;if

) ;cableRenum_PnI


;;;;;-----=====     subFunction:  cableRenum_increase     =====-----;;;;;


(defun cableRenum_increase ( / )

(setq tCt 1 i6List (cableRenum_sortList (append i8List i5List)))

(foreach i6 i6List
	(progn
		(foreach ia i6
			(progn
				(setq	tL (entget ia) 
					tNum (cond ((= (strlen (itoa tCt)) 1) (strcat "00" (itoa tCt)))
						   ((= (strlen (itoa tCt)) 2) (strcat "0" (itoa tCt)))
						   ((= (strlen (itoa tCt)) 3) (itoa tCt)))
					tVal (strcat (car t1) tNum)
					tL (subst (cons 1 tVal) (assoc 1 tL) tL)
				) ;setq
			(entmod tL)
			) ;progn
		) ;foreach

	(setq tCt (1+ tCt))
	) ;progn
) ;foreach

) ;cableRenum_increase


;;;;;-----=====     subFunction:  cableRenum_sortList     =====-----;;;;;


(defun cableRenum_sortList (xL)

(vl-sort xL
	'(lambda (a b)
		(or	
			(< 
				(cadr (assoc 11 (entget (car a))))
				(cadr (assoc 11 (entget (car b))))
			) ;< X X'

			(and	
				(equal 
					(cadr (assoc 11 (entget (car a))))
					(cadr (assoc 11 (entget (car b)))) 
				fD) ;equal X X'

				(> 
					(caddr (assoc 11 (entget (car a)))) 
					(caddr (assoc 11 (entget (car b))))
				) ;> Y Y'
			) ;and
		) ;or
	) ;lambda
) ;vl-sort

) ;cableRenum_sortList


;;;;;-----=====     subFunction:  cableRenum_Count     =====-----;;;;;


(defun cableRenum_Count (l / c l r x )

(while l
	(setq 	x (car l)
		c (length l)
		l (vl-remove x (cdr l))
		r (cons (cons x (- c (length l))) r)
	) ;setq
) ;while

(reverse r)

) ;cableRenum_Count


;**********************************    End of File     **********************************;

Re: Sort help

ВeekeeCZ — Thu, 26 Jan 2017 14:58:17 GMT

I did not dig into it very much, just blind shot... looks like it is working.

(defun cableRenum_sortList (xL)

(vl-sort xL
	'(lambda (a b)
		(or	
			(< 
				(atof (rtos (cadr (assoc 11 (entget (car a)))) 2 5))
				(atof (rtos (cadr (assoc 11 (entget (car b)))) 2 5))
			) ;< X X'

...

Re: Sort help

zph — Thu, 26 Jan 2017 16:09:33 GMT

It works for me!

You are as awesome as ever BeekeeCZ.

Thank you!

Re: Sort help

zph — Wed, 12 Apr 2017 14:44:11 GMT

BeeKeeCZ,

@ВeekeeCZ, May I ask for your assistance?

I am running into the same issue once again. See the attached drawing file.

Here is the full routine, with your addition of the (atof (rtos (....) 2 5)):

(defun c:cable_renum ( / adoc eFlag aList bList fD *error* ssBubs i8List cList cList2
			wP1 wP2 iList cTvLc tList eList i3List i4List i5List i6List i7List tVal iClist tCt tNum)

(vl-load-com)
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(setvar "cmdecho" 0)
(setq eFlag 1 ssBubs (ssadd)
	aList (list 	"A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" 
			"N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z")
	bList (list 	"LMR" "STACKWISE"))

;***************;
(setq fD 1.25)	; fuzz distance for text alignment in cableRenum_sortList
;***************;

(defun *error* (msg)
	(if (member msg '("quit / exit abort" "Conversion failed." "*Cancel*"))
		(progn (setvar "cmdecho" 1)(vla-endundomark adoc)
			(cond
				((= eFlag 1) (princ "\n <!> Routine aborted <!> "))
				((= eFlag 2) (princ "\n <!> Cable values adjusted <!> "))
			) ;cond
		) ;progn
	) ;if
) ;*error*

(cableRenum_getReady)
(cableRenum_getAllCables wP1 wP2)
(cableRenum_idBUBREFs wP1 wP2)
(cableRenum_consolidate)
(cableRenum_parse)

(if (> (sslength ssBubs) 0) (command "chprop" ssBubs "" "c" "1" ""))
(setq eFlag 2)
(exit)
) ;cable_renum


;;;;;-----=====     subFunction:  cableRenum_getReady     =====-----;;;;;


(defun cableRenum_getReady ()

(if 	(not 	(and 	(princ "\n\033\n Select two points for crossing window ")
			(setq wP1 (getpoint "\n <.> Select 1st point "))
			(setq wP2 (getpoint "\n <.> Select 2nd point "))
		) ;and
	) ;not

	(progn (princ "\n Two points required ")(exit))
	(progn (command "zoom" "w" wP1 wP2)(alert " Please, wait while routine completes\n\n\n...click OK to continue "))
) ;if

) ;cableRenum_getReady


;;;;;-----=====     subFunction:  cableRenum_getAllCables     =====-----;;;;;


(defun cableRenum_getAllCables (wP1 wP2 / allC tCntr aFlag tName tVal tLen tempL)

(if (setq allC (ssget "_C" wP1 wP2 '((0 . "TEXT")(8 . "TEXT")(67 . 0))) tCntr 0)
	(while (< tCntr (sslength allC))
	(setq aFlag "T" tName (ssname allC tCntr) tVal (cdr (assoc 1 (entget tName))) tLen (strlen tVal))	

		(if (>= tLen 3)
			(progn
			(setq tempL (mapcar 'chr (vl-string->list (substr tVal (- tLen 2)))))
			(foreach l tempL (if (member l aList) (setq aFlag "F")))
			(foreach b bList (if (= b (substr tVal 1 (strlen b))) (setq aFlag "F")))
			) ;progn
		) ;if

		(if	(and	(= aFlag "T")
				(> tLen 10)
				(wcmatch (substr tVal (- tLen 3) 1) "-")
				;(wcmatch (substr tVal (- tLen 7) 1) "-")
				(= (vl-string-search "," tVal) nil)
				(= (vl-string-search " " tVal) nil)
			) ;and	

		(setq iList (append iList (list tName)))
		) ;if

	(setq tCntr (1+ tCntr))
	) ;while

	(progn (princ "\n\033\n < Selection set empty > ")(exit))
) ;if

) ;cableRenum_getAllCables


;;;;;-----=====     subFunction:  cableRenum_idBUBREFs     =====-----;;;;;


(defun cableRenum_idBUBREFs (wP1 wP2 / ssC ssV cList vList vFlag cntrC cntrV cIpnt pt1 pt2 lpt1 lpt2 
				bFind lFind sPnt ePnt tFind)

(if (setq vFlag 0 cntrC 0 cntrV 0 ssC (ssget "_C" wP1 wP2 '((0 . "CIRCLE")(8 . "TEXT")(40 . 0.25))))
	(progn
	(setq ssV (ssget "X" '((0 . "LWPOLYLINE")(8 . "0,VIEWPORT")(67 . 0))))
	(while (< cntrC (sslength ssC)) (setq cList (cons (ssname ssC cntrC) cList) cntrC (1+ cntrC)))
	(while (< cntrV (sslength ssV)) (setq vList (cons (ssname ssV cntrV) vList) cntrV (1+ cntrV)))
	(if (= (getvar "tilemode") 0) (setvar "tilemode" 1))

		(foreach c cList
			(progn
			(setq vFlag 0 cIpnt (cdr (assoc 10 (entget c))))
			(vla-getboundingbox (vlax-ename->vla-object c) 'pt1 'pt2)
			(setq 	pt1 (vlax-safearray->list pt1) pt2 (vlax-safearray->list pt2)
				lpt1 (list (- (car pt1) 0.025) (- (cadr pt1) 0.025))
				lpt2 (list (+ (car pt2) 0.025) (+ (cadr pt2) 0.025)))	

				(if (setq bFind (ssget "X" (list	
					'(0 . "TEXT")'(8 . "TEXT")'(67 . 0)
					'(-4 . "<AND")
					'(-4 . ">,>,=") (cons 10 (list (car pt1) (cadr pt1)))
					'(-4 . "<,<,=") (cons 10 (list (car pt2) (cadr pt2)))
					'(-4 . "AND>"))))

(foreach v vList
	(if (= vFlag 0)
		(progn
		(vla-getboundingbox (vlax-ename->vla-object v) 'pt1 'pt2)
		(setq pt1 (vlax-safearray->list pt1) pt2 (vlax-safearray->list pt2))

			(if	(and	(>= (car cIpnt) (car pt1))(>= (cadr cIpnt) (cadr pt1))
					(<= (car cIpnt) (car pt2))(<= (cadr cIpnt) (cadr pt2)))
							
(if (setq lFind (ssget "_C" lpt1 lpt2 '((0 . "LINE")(8 . "WIRE")(67 . 0))))

	(if	(setq	sPnt (cdr (assoc 10 (entget (ssname lFind 0))))
			ePnt (cdr (assoc 11 (entget (ssname lFind 0))))
			tFind (ssget "_W" sPnt (list (car ePnt) (+ (cadr ePnt) 0.25)) 
				'((0 . "TEXT")(8 . "TEXT")(67 . 0))))
	
		(setq vFlag 1 cTvLc (cons (list
			c 
			(ssname bFind 0)
			(cdr (assoc 1 (entget (ssname bFind 0))))
			v 	
			(ssname lFind 0) 
			(ssname tFind 0)
			(cdr (assoc 1 (entget (ssname tFind 0))))) cTvLc))
	) ;if
) ;if
			) ;if
		) ;progn
	) ;if
) ;foreach
				) ;if
			) ;progn
		) ;foreach
	) ;progn
) ;if

) ;cableRenum_idBUBREFs


;;;;;-----=====     subFunction:  cableRenum_consolidate     =====-----;;;;;


(defun cableRenum_consolidate ( / zList rFlag cVal)

(foreach c cTvLc (setq zList (cons (list (nth 5 c) (nth 1 c)) zList)))

(foreach iL iList
	(progn
	(setq rFlag "F" cVal (cdr (assoc 1 (entget iL))))
	(foreach z zList (if (equal iL (car z)) (setq rFlag "T")))
	(if (= rFlag "F") (setq i3List (cons (list iL) i3List)))

		(if (= (member (list (substr cVal 1 (- (strlen cVal) 3))) tList) nil)
		(setq tList (cons (list (substr cVal 1 (- (strlen cVal) 3))) tList))
		) ;if
	) ;progn
) ;foreach

(foreach z zList
	(setq 	i4List (cons (list 
				(nth 0 z)
				(cdr (assoc 1 (entget (nth 0 z))))
				(cdr (assoc 1 (entget (nth 1 z))))) i4List)
		i7List (cons (cdr (assoc 1 (entget (nth 1 z)))) i7List)
	) ;setq
) ;foreach

(setq 	i7List (cableRenum_Count i7List)
	eList (append i3List i4List)
 	tList (vl-sort tList '(lambda (x y) (< (car x) (car y)))))

) ;cableRenum_consolidate


;;;;;-----=====     subFunction:  cableRenum_parse     =====-----;;;;;


(defun cableRenum_parse ( / tCt sCntr sCntr3 tRlist tSlist tTlist tUlist tVlist tUlen i7len i8List tUl itQA sCntr2)

(foreach t1 tList			
	(progn
	(setq sCntr 0 tSlist () i5List () tRlist () i8List ())
		(foreach e1 eList
			(if	(and	(not (= eList nil))
					(not (= e1 nil))
					(equal  
						(substr 
							(cdr (assoc 1 (entget (car e1)))) 
							1 
							(- (strlen (cdr (assoc 1 (entget (car e1))))) 3)
						) ;substr
						(car t1)
					) ;equal
				) ;and

				(progn
				(cableRenum_PnI)
				(cableRenum_increase)
				) ;progn
			) ;if
		) ;foreach
	) ;progn
) ;foreach

) ;cableRenum_parse


;;;;;-----=====     subFunction:  cableRenum_PnI     =====-----;;;;;


(defun cableRenum_PnI ( / )

(if (= (member e1 i4List) nil)
	(setq i8List (cons e1 i8List))

	(progn
	(setq 	tTlist () tUlist () tVlist () 
		itQA 0
		sCntr3 0 
		i4List (vl-sort i4List '(lambda (x y) (< (caddr x) (caddr y)))))

		(while (< sCntr (length i4List))
			(foreach i7 i7List		; find QAs of BUBREFs
			(if (= (caddr (nth sCntr i4List)) (car i7)) (setq itQA (cdr i7)))
			) ;foreach

		(setq tRlist () sCntr2 0 titQA (+ itQA sCntr3))

			(while (< sCntr3 titQA)
			(setq 	tRlist (append tRlist (list (nth sCntr3 i4List)))
				sCntr3 (1+ sCntr3))
			) ;while

			(setq 	tSlist (cableRenum_sortList tRlist) 
				sCntr (+ sCntr itQA) 
				sCntr2 0
				tTlist (append tTlist (list tSlist))
			) ;setq

			(foreach tT tTlist
				(progn
				(setq tUlist ())
					(foreach ta tT
						(setq tUlist 
							(append tUlist 
								(list (car ta))
							) ;append
						) ;setq
					) ;foreach
				(setq tVlist (append tVlist (list tUlist)))
				) ;progn
			) ;foreach					
		) ;while

		(setq tSlist tTlist)

	(setq i7len (length i7List) tRlist ())

		(while (> i7len 0)
			(setq 	tRlist (cons (last tVlist) tRlist)
				tVlist (vl-remove (last tVlist) tVlist)
				i7len (1- i7len)
			) ;setq
		) ;while

		(foreach tS tSlist
			(if (or (= (length tS) 1)(> (length tS) 2))
			(foreach ta tS (setq ssBubs (ssadd (car ta) ssBubs)))
			) ;if
		) ;foreach

	(setq i5List tRlist)
	) ;progn
) ;if

) ;cableRenum_PnI


;;;;;-----=====     subFunction:  cableRenum_increase     =====-----;;;;;


(defun cableRenum_increase ( / )

(setq tCt 1 i6List (cableRenum_sortList (append i8List i5List)))

(foreach i6 i6List
	(progn
		(foreach ia i6
			(progn
				(setq	tL (entget ia) 
					tNum (cond ((= (strlen (itoa tCt)) 1) (strcat "00" (itoa tCt)))
						   ((= (strlen (itoa tCt)) 2) (strcat "0" (itoa tCt)))
						   ((= (strlen (itoa tCt)) 3) (itoa tCt)))
					tVal (strcat (car t1) tNum)
					tL (subst (cons 1 tVal) (assoc 1 tL) tL)
				) ;setq
			(entmod tL)
			) ;progn
		) ;foreach

	(setq tCt (1+ tCt))
	) ;progn
) ;foreach

) ;cableRenum_increase


;;;;;-----=====     subFunction:  cableRenum_sortList     =====-----;;;;;


(defun cableRenum_sortList (xL)

(vl-sort xL
	'(lambda (a b)
		(or	
			(< 
				(atof (rtos (cadr (assoc 11 (entget (car a)))) 2 5))
				(atof (rtos (cadr (assoc 11 (entget (car b)))) 2 5))
			) ;< X X'

			(and	
				(equal 
					(cadr (assoc 11 (entget (car a))))
					(cadr (assoc 11 (entget (car b))))
				fD) ;equal X X'

				(> 
					(caddr (assoc 11 (entget (car a)))) 
					(caddr (assoc 11 (entget (car b))))
				) ;> Y Y'
			) ;and
		) ;or
	) ;lambda
) ;vl-sort

) ;cableRenum_sortList


;;;;;-----=====     subFunction:  cableRenum_Count     =====-----;;;;;


(defun cableRenum_Count (l / c l r x )

(while l
	(setq 	x (car l)
		c (length l)
		l (vl-remove x (cdr l))
		r (cons (cons x (- c (length l))) r)
	) ;setq
) ;while

(reverse r)

) ;cableRenum_Count

What is difference between the two columns of cable numbers? The column on the left renumbers appropriately while the column on the right does not.

Re: Sort help

ВeekeeCZ — Wed, 12 Apr 2017 15:49:21 GMT

Hi, I did the same thing as before with the other comparisons as well, lower the precision and it works...

(defun cableRenum_sortList (xL)
  
  (vl-sort xL
           '(lambda (a b)
              (or
                (<
                  (atof (rtos (cadr (assoc 11 (entget (car a)))) 2 1))
                  (atof (rtos (cadr (assoc 11 (entget (car b)))) 2 1))
                  ) ;< X X'
                
                (and
                  (equal
                    (atof (rtos (cadr (assoc 11 (entget (car a)))) 2 1))
                    (atof (rtos (cadr (assoc 11 (entget (car b)))) 2 1))
                    fD) ;equal X X'
                  
                  (>
                    (atof (rtos (caddr (assoc 11 (entget (car a)))) 2 1))
                    (atof (rtos (caddr (assoc 11 (entget (car b)))) 2 1))
                    ) ;> Y Y'
                  ) ;and
                ) ;or
              ) ;lambda
           ) ;vl-sort
  
  ) ;cableRenum_sortList

Re: Sort help

zph — Wed, 12 Apr 2017 20:21:41 GMT

Thank you for the response, BeeKeeCZ.

It worked on the test file.

However, I went back to 'real' file and it didn't work 😕

Re: Sort help

ВeekeeCZ — Thu, 13 Apr 2017 08:06:03 GMT

Have you tried trace the process to see where it fails? Step by step. Do you know how to do that?

HERE is a simple example how it works.