;; SSINDEX.LSP  Copyright 2000  Tony Tanzillo
;;
;; Functions to sort/index the entities in
;; a selection set using arbitrary sorting
;; criteria.
;;
;; See the C:TEXTINDEX and C:TEXTINDEX-XY
;; command functions below for typical 
;; examples of how to use of (ss-index).

;; (list-index <list> <OnCompare>)
;;
;; Sorts <list> and returns a list of
;; integers representing the indices of
;; the elements in <list> in their sorted
;; order, as defined by <OnCompare>, which
;; is a function that takes two elements
;; and returns a value that when logically
;; interpreted, indicates the relationship
;; between the two values.

(defun list-index (input func / i)
   (setq i -1)
   (mapcar 'cdr
      (vl-sort 
         (mapcar 
           '(lambda (val)
               (cons val (setq i (1+ i)))
            )
            input
         )
        '(lambda (a b)
            (apply func (mapcar 'car (list a b)))
         )
      )
   )
)

;; (ss-index <ss> <OnGetKey> <OnCompareKey>)
;;
;;  where:
;;
;;     (<OnGetKey> <ename>)
;;
;;     (<OnCompareKey> <Key1> <Key2>)
;;
;; Returns a list of integers representing the
;; indices of the elements in the selection set <ss>
;; in the sorted order, where the <OnGetKey> function
;; takes each entity name in the selection set, and
;; returns that entity's sort key, and <OnCompareKey>
;; takes the sort keys of two entities, and returns
;; a value whose logical interpretation indicates the
;; relationship of the two keys.
  

(defun ss-index (ss _getKey _compareKey / keylist i)
   (repeat (setq i (sslength ss))
      (setq keylist 
         (cons 
            (apply _getKey (list (ssname ss (setq i (1- i)))))
            keylist
         )
      )
   )
   (list-index keylist _compareKey)
)

;; Test SS-INDEX. Prompts for a selection set of text,
;; and appends an integer to each text's value string,
;; which is the index of the text in the sorted order.

(defun C:TEXTINDEX ( / ss indices oldtext)
   (setq ss (ssget '((0 . "TEXT"))))
   (setq indices 
      (ss-index ss
        '(lambda (ename) 
            (caddr (assoc 10 (entget ename))) ;; sort key = Y-ordinate 
         )
        '>   ;; sort comparison function = < (is-greater-than)
      )
   )
   (setq j -1)
   (foreach i indices
      (setq e (ssname ss i))
      (setq oldtext (cdr (assoc 1 (entget e))))
      (entmod 
         (list
            (cons -1 e)
            (cons 1 
               (strcat 
                  oldtext 
                  " ( " 
                  (itoa (setq j (1+ j))) 
                  " ) "
               )
            )
         )
      )
   )
)


;; This example is similar to the above one,
;; except that it sorts the text on both the
;; X and Y ordinates of its insertion point
;; (note that this code assumes that all of
;; the text is left-justified).
;; 
;; To set up a scenario for testing this code,
;; create a single text object, then use the
;; ARRAY command to create an M X N rectangular
;; array of text objects. Then, run this command
;; and select the entire array of text.

(setq epsilon 1.0e-6)

;; Sort coordinates first on Y component,
;; then on the X component:

(defun compare-points (p1 p2)
   (if (equal (cadr p1) (cadr p2) epsilon)
      (< (car p1) (car p2))
      (> (cadr p1) (cadr p2))
   )
)

(defun C:TEXTINDEX-XY ( / ss indices oldtext)
   (command "._UNDO" "_Begin")
   (setq ss (ssget '((0 . "TEXT"))))
   (setq indices 
      (ss-index ss
        '(lambda (ename) 
            (cdr (assoc 10 (entget ename)))  ;; cache entire point 
         )                                   ;; as sort key
        'compare-points  ;; comparison function 
      )
   )
   (setq j -1)
   (foreach i indices
      (setq e (ssname ss i))
      (setq oldtext (cdr (assoc 1 (entget e))))
      (entmod 
         (list
            (cons -1 e)
            (cons 1 
               (strcat 
                  oldtext 
                  "(" 
                  (itoa (setq j (1+ j))) 
                  ")"
               )
            )
         )
      )
   )
   (command "._UNDO" "_END")
)

(defun lsort (input OnCompare / fun)
   (setq fun (cond (OnCompare) (t '>)))
   (lsort-aux input)
)

(if (not vl-sort)
   (setq vl-sort lsort)
)

(defun lsort-aux (input)
   (if (cdr input)
      (  (lambda (tlist)
            (lsort-merge 
               (lsort-aux (car tlist))
               (lsort-aux (cadr tlist))
            )
         )
         (lsort-split input)
      )
      input
   )
)

(defun lsort-split (right / left)
   (repeat (/ (length right) 2)
      (setq
         left (cons (car right) left)
         right (cdr right)
      )
   )
   (list left right)
)

(defun lsort-merge (left right / out)
   (while (and left right)
      (if (apply fun (list (car left) (car right)))
         (setq
            out (cons (car left) out)
            left (cdr left)
         )
         (setq
            out (cons (car right) out)
            right (cdr right)
         )
      )
   )
   (append (reverse out) left right)
)