;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
;;; *                                                                   *
;;; *            H E R M A N  G O L D N E R  C O M P A N Y              *
;;; *                                                                   *
;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
;;;
;;; File       : hgsort.lsp
;;; Date       : 8-6-96
;;; Purpose    : Samples of power sorting in AutoLisp
;;;
;;; Author     : T.J. DiTullio   Herman Goldner Co. Inc.
;;;              (70214,3131)   E-Mail - tditullio@goldner.com
;;;
;;; Date       : 3-23-95 (complied from earlier files 1992)
;;;            : Revised 8-6-96 to add sorting "Method" and
;;;            : and added (xysort) from seperate file
;;;
;;; Desciption : Here are five sorting functions that implement
;;;              sorting with pointers (Yes in AutoLisp).
;;;              There are two shell sorts and two bubble sorts.
;;;              One of each for lists and one for list of lists
;;;              and one two dimensional sort.
;;;
;;;              After I developed these functions, I speed tested
;;;              the shells against the bubbles. Since then I have not
;;;              used the bubble sorts.
;;;
;;;              All four functions use an integer list (ptr_lst) as
;;;              pointers to the list to be sorted. One problem with
;;;              sorting in AutoLisp is that the list to be sorted must
;;;              be reconstructed each time a pair of items are swapped
;;;              If the list (or list of lists) is very large, it can
;;;              slow down the sort. By using a pointer list of type
;;;              integer, this reconstruction will be much faster.
;;;
;;;              At the start of each sort function, an integer list
;;;              (ptr_lst) is constructed starting at 0 and ending at
;;;              the number of items in list to be sorted (length lst).
;;;              As items in the list to be sorted are compared, the
;;;              pointer list is used to reference the list to be sorted.
;;;              [ something like (nth (nth index ptr_lst) lst) ]
;;;              [ meaning - The value of the list to be sorted is still
;;;                          in its original location. Used the integer
;;;                          (ptr_lst) value to determine where it is.
;;;              ]
;;;              Since the pointer list starts at 0, I used value of -1
;;;              for the 1st (subst) call to avoid have duplicate values in
;;;              the pointer list that would both be updated on the 2nd
;;;              (subst) call. Then after the 2nd (subst) call, a 3rd call
;;;              is made to replace the -1 value with the correct value.
;;;                  (setq t1 1st_item) - save 1st
;;;                  (setq t2 2nd_item) - save 2nd
;;;                  (subst -1 t1)      - change t1 to -1
;;;                  (subst t1 t2)      - change t2 to t1
;;;                  (subst t2 -1)      - change -1 to t2
;;;                                     - t1 and t2 are >= 0  always
;;;
;;;              As items are swapped around, only the pointer list is
;;;              modified. After the sorting is completed, the list to
;;;              be sorted to rebuilt using the pointer list for the
;;;              sorted location.
;;;
;;;              This may seem like a lot of work to do some sorting. But
;;;              the list of list that I sort get very large. (I use list
;;;              of lists like an array of structures for anyone who knows
;;;              the C language)
;;;
;;;              Here is an example for a list of lists I might sort:
;;;              ( ( "string" integer real integer real real "string"
;;;                  "string" real integer "string" real
;;;                )
;;;                ( "string" integer real integer real real "string"
;;;                  "string" real integer "string" real
;;;                )
;;;                etc ...
;;;              )
;;;
;;;    lisp call   -> (setq mylist (l_ssort mylist 3 '>))
;;;    lisp retn   -> sorted list
;;;    description -> sort mylist bases on the 4th item (an integer)
;;;                     in ascending order
;;;
;;;
;;;              One thing I noticed when I wrote these sorts was that
;;;              a shell sort is unable to sort completely if there are
;;;              duplicate values. I could not find anything in writing
;;;              to back this up. So I modified the algorithm to continue
;;;              looping while the partition size is one until no swaps
;;;              occurred.
;;;
;;;              Sorry there are not a lot of comments!
;;;
;;;              If you program in AutoLisp and are unfamiliar with these
;;;              sorting methods, try looking at another language like
;;;              Basic or C.
;;;
;;;              Any comments or questions can be directed to me.
;;;
;;;   *** Revision 8-6-96 ***
;;;
;;;              All five sorting functions now except another parameter
;;;              "method", a (quoted) function.
;;;              Ex. (ssort some_list '>)  - ascending order
;;;                  (ssort some_list '<)  - descending order
;;;
;;;              You can also use a function other than > or < for the
;;;              sorting method. That function could expand the nested
;;;              level even further the a list of lists.
;;;
;;;              Ex.  (defun sort_method (a b)
;;;                     (if (> (nth 0 a) (nth 0 b)
;;;                       T    ;then return TRUE
;;;                       nil  ;esle return FALSE
;;;                     )
;;;                   )
;;;
;;;                   (l_ssort list1 1 'sort_method)
;;;
;;;                   This SHOULD (I think, didn't test it) sort list1
;;;                   by the first element of the lists that are the second
;;;                   elements in the list of lists, OR SOMETHING, in
;;;                   ascending order.
;;;
;;;                   list1 = ( (1 (1 2 1) 1)  (1 (2 1 1) 1)  (2 (1 3 3) 3) )
;;;                                 ^-- this is the "KEY" item
;;;                                  first element of the list
;;;                                  that is the second element of the bigger
;;;                                  lists that make up "LIST1"
;;;
;;;
;;;     WARNING: IF YOU ARE ALREADY USING THESE FUNCTIONS FROM AN EARLIER
;;;              VERSIONS, YOU MUST EITHER RENAME THE NEW ONES OR EDIT
;;;              ALL CALLS IN ANY EXISTING PROGRAMS TO INCLUDE THE NEW
;;;              "method" PARAMETER.
;;;
;;;=======================================================================
;;;
;;;  THIS CODE IS THE PROPERTY OF T.J. DITULLIO AND THE HERMAN GOLDNER CO INC
;;;  PERMISSION IS GRANTED TO USE, COPY, MODIFY, AND DISTRIBUTE WITHOUT FEE
;;;  PROVIDED THAT THIS NOTICE IS DISTRIBUTED.
;;;
;;;=======================================================================
;;;  Sample Usage
;;;
;;;  Command: !lst
;;;  ((1 1 1) (2 2 2) (1 1 1) (3 3 3) (3 1 1) (0 0 0)
;;;   (1 1 1) (2 2 2) (1 1 1) (3 3 3) (3 1 1) (0 0 0))
;;;
;;;  Command: (l_ssort lst 0 '>)
;;;  ((0 0 0) (0 0 0) (1 1 1) (1 1 1) (1 1 1) (1 1 1)
;;;   (2 2 2) (2 2 2) (3 1 1) (3 3 3) (3 1 1) (3 3 3))
;;;
;;;  Command: (l_ssort lst 0 '<)
;;;  ((3 3 3) (3 1 1) (3 3 3) (3 1 1) (2 2 2) (2 2 2)
;;;   (1 1 1) (1 1 1) (1 1 1) (1 1 1) (0 0 0) (0 0 0))
;;;
;;;  Command: (l_bsort lst 1 '<)
;;;  ((3 3 3) (3 3 3) (2 2 2) (2 2 2) (1 1 1) (1 1 1)
;;;   (3 1 1) (1 1 1) (1 1 1) (3 1 1) (0 0 0) (0 0 0))
;;;
;;;  Command: (l_bsort lst 1 '>)
;;;  ((0 0 0) (0 0 0) (1 1 1) (1 1 1) (3 1 1) (1 1 1)
;;;   (1 1 1) (3 1 1) (2 2 2) (2 2 2) (3 3 3) (3 3 3))
;;;
;;;  Command: (xysort lst 0 1 '>)
;;;  ((0 0 0) (0 0 0) (1 1 1) (1 1 1) (1 1 1) (1 1 1)
;;;   (2 2 2) (2 2 2) (3 1 1) (3 1 1) (3 3 3) (3 3 3))
;;;
;;;  Command: (xysort lst 0 2 '<)
;;;  ((3 3 3) (3 3 3) (3 1 1) (3 1 1) (2 2 2) (2 2 2)
;;;   (1 1 1) (1 1 1) (1 1 1) (1 1 1) (0 0 0) (0 0 0))
;;;
;;;
;;;* * * * * * * * * * * * * SORT FUNCTIONS  * * * * * * * * * * * * * * *
;;;
;;; l_bsort
;;;
;;; Modified Bubble Sort of List of Lists
;;; Parameters   llist ->  list of lists
;;;              key   ->  element in inner lists to sort by
;;;             method ->  '> for ascending or '< for descending
;;;
;;; Returns  ->  Sorted list of lists
;;;

(defun l_bsort ( llist key method /   number_items  count     i
                                      unsorted      ptr_lst   j
                                      sorted_list   t1        t2
               )
  (if (and llist key)
    (progn
      (setq i 1
            number_items (length llist)
            unsorted T
            ptr_lst nil          ;pointer list
            count 0
      )

      (while (< count number_items)
        (setq ptr_lst (append ptr_lst (list count))  ;built pointer list
              count (1+ count)
        )
      ) ;while

    ;-----------------------------------------------------------------------

      (while (or unsorted (< i number_items))
        (setq j 0
              unsorted nil       ;assume list is sorted
        )

        ;loop thru and test (j) to (J+1) in pointer list

        (while (< j (- number_items i))
            (if ((eval method) (nth key (nth (nth j ptr_lst) llist))
                               (nth key (nth (nth (1+ j) ptr_lst) llist))
                )

              ; swap items in pointer list
              (setq t1 (nth j ptr_lst)
                    t2 (nth (1+ j) ptr_lst)
                    ptr_lst (subst t2 -1
                              (subst t1 t2
                                (subst -1 t1 ptr_lst)
                              )
                            )
                    unsorted T
              ) ;setq
            ) ;if

          (setq j (1+ j))
        ) ;while j

        (setq i (1+ i))
      ) ;while i

    ;-----------------------------------------------------------------------
      ;Build new list using sorted pointers

      (setq count 0 sorted_list nil)
      (while (< count number_items)
        (setq sorted_list
                (append sorted_list        ;build updated list
                  (list
                    (nth
                      (nth count ptr_lst)  ;pointer
                      llist
                    )
                  )
                )
              count (1+ count)
        ) ;setq
      ) ;while

      sorted_list                          ;return sorted list
    ) ;progn

    ;else
    nil
  ) ;if

) ;defun

;;;=======================================================================
;;;
;;; l_ssort
;;;
;;; Modified Shell Sort of List of Lists
;;; Parameters   llist ->  list of lists
;;;              key   ->  element in inner lists to sort by
;;;             method ->  '> for ascending or '< for descending
;;;
;;; Returns  ->  Sorted list of lists
;;;
;;; Note: This custom shell sort algorithm will handle multiple
;;;       occurrences of any items. The sort will continue looping
;;;       when partition size is 1 until no swaps occur.
;;;

(defun l_ssort (llist key method /
                              number_items       partition_size
                              number_partitions  first_index
                              last_index         unsorted
                              count              ptr_lst
                              sorted_list        i         j
                              t1                 t2
                 )

  (if (and llist key)
    (progn
      (setq number_items (length llist)
            partition_size number_items
            ptr_lst nil                  ;pointer list
            count 0
            unsorted T                   ;assume list is not sorted
      )

		(if #Verbose (princ "\nBuilding point list..."))
		(while (< count number_items)
			(setq
				ptr_lst (append ptr_lst (list count)) ;built pointer list
				count (1+ count)
			)
		)
		(if #Verbose (princ "done."))

    ;------------------------------------------------------------------

      (while unsorted

        (setq partition_size (fix (/ (1+ partition_size) 2))
              number_partitions (fix (/ number_items partition_size))
        )

		(if #Verbose
			(princ (strcat "\nNumber of partitions = " (itoa number_partitions) "                 \n"))
		)

        (if (= partition_size 1)
          (setq unsorted nil)       ;assume list is sorted
        )

        (if (/= (rem number_items partition_size) 0)
          (setq number_partitions (1+ number_partitions))
        )
        (setq first_index 0
              i 1
        )
        (while (< i number_partitions)
			(if #Verbose
				(princ (strcat "\r" (itoa i) " --> " (itoa number_partitions) "                 "))
			)
          (setq last_index (+ first_index partition_size))

          (if (> last_index (- number_items partition_size))
            (setq last_index (- number_items partition_size))
          )

          ; loop thru and test (j) to (j+offset) in pointer list

          (setq j first_index)
          (while (< j last_index)
            (if ((eval method) (nth key (nth (nth j ptr_lst) llist))
                               (nth key (nth
                                 (nth (+ j partition_size) ptr_lst) llist)
                               )
                )

              ; then swap items in pointer list
              (setq t1 (nth j ptr_lst)
                    t2 (nth (+ j partition_size) ptr_lst)
                    ptr_lst (subst t2 -1
                              (subst t1 t2
                                (subst -1 t1 ptr_lst)
                              )
                            )
                    unsorted T
              ) ;setq
            ) ;if

            (setq j (1+ j))

          ) ;while j

          (setq first_index (+ first_index partition_size)
                i (1+ i)
          )

        ) ;while i


      ) ;while unsorted

    ;------------------------------------------------------------------
      ;Build new list using sorted pointers

      (setq count 0 sorted_list nil)
      (while (< count number_items)
        (setq sorted_list
                (append sorted_list        ;build updated list
                  (list
                    (nth
                      (nth count ptr_lst)  ;pointer
                      llist
                    )
                  )
                )
              count (1+ count)
        ) ;setq
      ) ;while

      sorted_list                          ;return sorted list
    ) ;progn

    ;else
    nil
  ) ;if

) ;defun

;;;=======================================================================
;;;
;;; bsort
;;;
;;; Modified Bubble Sort of List of values
;;; Parameters   lst   ->  list of values
;;;             method ->  '> for ascending or '< for descending
;;;
;;; Returns  ->  Sorted list of values
;;;


(defun bsort ( lst method /   number_items  count     i
                              unsorted      ptr_lst   j
                              sorted_list   t1        t2
             )
  (if lst
    (progn
      (setq i 1
            number_items (length lst)
            unsorted T
            ptr_lst nil          ;pointer list
            count 0
      )

      (while (< count number_items)
        (setq ptr_lst (append ptr_lst (list count))  ;built pointer list
              count (1+ count)
        )
      ) ;while

    ;-----------------------------------------------------------------------

      (while (or unsorted (< i number_items))
        (setq j 0
              unsorted nil       ;assume list is sorted
        )

        ;loop thru and test (j) to (J+1) in pointer list

        (while (< j (- number_items i))
            (if ((eval method) (nth (nth j ptr_lst) lst)
                               (nth (nth (1+ j) ptr_lst) lst)
                )

              ; swap items in pointer list
              (setq t1 (nth j ptr_lst)
                    t2 (nth (1+ j) ptr_lst)
                    ptr_lst (subst t2 -1
                              (subst t1 t2
                                (subst -1 t1 ptr_lst)
                              )
                            )
                    unsorted T
              ) ;setq
            ) ;if

          (setq j (1+ j))
        ) ;while j

        (setq i (1+ i))
      ) ;while i

    ;-----------------------------------------------------------------------
      ;Build new list using sorted pointers

      (setq count 0 sorted_list nil)
      (while (< count number_items)
        (setq sorted_list
                (append sorted_list        ;build updated list
                  (list
                    (nth
                      (nth count ptr_lst)  ;pointer
                      lst
                    )
                  )
                )
              count (1+ count)
        ) ;setq
      ) ;while

      sorted_list                          ;return sorted list
    ) ;progn

    ;else
    nil
  ) ;if

) ;defun

;;;=======================================================================
;;;
;;; ssort
;;;
;;; Modified Shell Sort of List of Values
;;; Parameters   lst ->  list of values
;;;             method ->  '> for ascending or '< for descending
;;;
;;; Returns  ->  Sorted list of values
;;;
;;; Note: This custom shell sort algorithm will handle multiple
;;;       occurrences of any items. The sort will continue looping
;;;       when partition size is 1 until no swaps occur.
;;;

(defun ssort (lst method /
                       number_items       partition_size
                       number_partitions  first_index
                       last_index         unsorted
                       count              ptr_lst
                       sorted_list        i         j
                       t1                 t2
                 )

  (if lst
    (progn
      (setq number_items (length lst)
            partition_size number_items
            ptr_lst nil                  ;pointer list
            count 0
            unsorted T                   ;assume list is not sorted
      )

      (while (< count number_items)
        (setq ptr_lst (append ptr_lst (list count)) ;built pointer list
              count (1+ count)
        )
      ) ;while

    ;------------------------------------------------------------------

      (while unsorted

        (setq partition_size (fix (/ (1+ partition_size) 2))
              number_partitions (fix (/ number_items partition_size))
        )

        (if (= partition_size 1)
          (setq unsorted nil)       ;assume list is sorted
        )

        (if (/= (rem number_items partition_size) 0)
          (setq number_partitions (1+ number_partitions))
        )
        (setq first_index 0
              i 1
        )
        (while (< i number_partitions)
          (setq last_index (+ first_index partition_size))

          (if (> last_index (- number_items partition_size))
            (setq last_index (- number_items partition_size))
          )

          ;loop thru and test (j) to (j+offset) in pointer list

          (setq j first_index)
          (while (< j last_index)
            (if ((eval method) (nth (nth j ptr_lst) lst)
                               (nth (nth (+ j partition_size) ptr_lst) lst)
                )

              ; then swap items in pointer list
              (setq t1 (nth j ptr_lst)
                    t2 (nth (+ j partition_size) ptr_lst)
                    ptr_lst (subst t2 -1
                              (subst t1 t2
                                (subst -1 t1 ptr_lst)
                              )
                            )
                    unsorted T
              ) ;setq
            ) ;if

            (setq j (1+ j))

          ) ;while j

          (setq first_index (+ first_index partition_size)
                i (1+ i)
          )

        ) ;while i


      ) ;while unsorted

    ;------------------------------------------------------------------
      ;Build new list using sorted pointers

      (setq count 0 sorted_list nil)
      (while (< count number_items)
        (setq sorted_list
                (append sorted_list        ;build updated list
                  (list
                    (nth
                      (nth count ptr_lst)  ;pointer
                      lst
                    )
                  )
                )
              count (1+ count)
        ) ;setq
      ) ;while

      sorted_list                          ;return sorted list
    ) ;progn

    ;else
    nil
  ) ;if

) ;defun

;;;========================================================================
;;;
;;; xysort
;;;
;;; Two-dimensional sorting function
;;; Calls l_ssort
;;;
;;; Parameters   llist ->  list of values
;;;                  x ->  primary key location
;;;                  y ->  secondary key location
;;;             method ->  '> for ascending or '< for descending
;;;
;;; Returns  ->  Sorted list of values
;;;

(defun xysort (llist x y method
                         / count1 llist_len sublist newlist key
              )
  (cond
    ( (= x y)
        (princ "\nError: X and Y values are equal.")
        (princ)
    )
    ( (>= x (length (nth 0 llist)))
        (princ "\nError: X value greater than list length.")
        (princ)
    )
    ( (>= y (length (nth 0 llist)))
        (princ "\nError: Y value greater than list length.")
        (princ)
    )
    ( T
        (setq llist (l_ssort llist x method)   ;first sort by x
              count1 0
              llist_len (length llist)
              sublist ()
              newlist ()
        )
        (while (< count1 (1- llist_len))
          (setq key (nth x (nth count1 llist))
                count2 (1+ count1)     ;next element after count1
                sublist (append (list (nth count1 llist)))   ;add first x
          )

          (while (and
                   (< count2 llist_len)
                   (= (nth x (nth count2 llist)) key) ;while x's are equal
                 )
            (setq sublist (append sublist (list (nth count2 llist)))
                  count1 (1+ count1)
                  count2 (1+ count2)
            )
          ) ;while =
          (setq sublist (l_ssort sublist y method)        ;sort by y
                newlist (append newlist sublist)
                count1 (1+ count1)
          )
        ) ;while <
        (if (< count1 llist_len)
          (setq newlist (append newlist (list (nth count1 llist))))
        )

        newlist       ;return x-y sorted list
   ) ;case T
 )  ;cond
) ;defun
;;;========================================================================

(princ)