;-------------------------------------------------------------------------------
; Program Name: Win_Sort.lsp [Win_Sort R1]
; Created By:   Terry Miller (Email: terrycadd@yahoo.com)
;               (URL: http://web2.airmail.net/terrycad)
; Date Created: 5-20-07
; Function:     The Win_Sort function sorts a list of strings or filenames very
;               similar to the way Windows sorts files in folders.  It may be
;               used to display filenames in a dialog list, and may also be used
;               in a plot script function to plot a folder of drawings in the
;               Windows sorted order other than just the acad_strlsort order.
;               Also included are the dependant functions number_sort for
;               sorting numbers, and the change_nth and delete_nth functions.
; Note:         To test the Win_Sort functions run the c:Win_Demo function.
;-------------------------------------------------------------------------------
; Revision History
; Rev  By     Date    Description
;-------------------------------------------------------------------------------
; 1    TM   5-20-07  Initial version
;-------------------------------------------------------------------------------
; win_sort - Windows type of sort function
; Arguments: 1
;   List@ = List of strings or filenames
; Returns: List of strings sorted similar to how Windows sorts files
;-------------------------------------------------------------------------------
(defun win_sort (Original@ / AlphaSort@ Cnt# Compare$ First Item List@ Loop
  Next$ Num# NumSort@ NumStrings@ Passed Prefix$ Prefixes@ PrefixList@
  PrefixSort@ Previous$ SortLenghts@ SortList@ Str$)
  (setq Passed t)
  (if (= (type Original@) 'LIST)
    (foreach Item Original@ (if (/= (type Item) 'STR) (setq Passed nil)))
    (setq Passed nil)
  );if
  (if (not Passed)
    (progn (princ "\nUsage: (win_sort <list of strings>)") (exit))
  );if
  (setq Original@ (acad_strlsort Original@))
  (setq AlphaSort@ (mapcar 'strcase Original@))
  (setq Num# 0 Next$ (chr 160));a unique character
  (repeat (length AlphaSort@)
    (setq Previous$ Next$
          Next$ (nth Num# AlphaSort@)
          Prefix$ nil
          Cnt# 1
    );setq
    (if (not (wcmatch (substr Next$ 1 1) "#"))
      (repeat (strlen Next$)
        (setq Str$ (substr Next$ 1 Cnt#)
              Compare$ (strcat Str$ "*")
        );setq
        (if (and (wcmatch Previous$ Compare$)(not (wcmatch (substr Str$ (strlen Str$)) "#")))
          (setq Prefix$ Str$)
        );if
        (setq Cnt# (1+ Cnt#))
      );repeat
    );if
    (if Prefix$
      (progn
        (setq Compare$ (strcat Prefix$ "#*"))
        (if (and (wcmatch Previous$ Compare$)(wcmatch Next$ Compare$))
          (setq Passed t)
          (setq Passed nil)
        );if
      );progn
    );if
    (if (and Passed Prefix$ (not (member Prefix$ Prefixes@)))
      (setq Prefixes@ (append Prefixes@ (list Prefix$)))
    );if
    (setq Num# (1+ Num#))
  );repeat
  (if Prefixes@
    (progn
      (if (> (length Prefixes@) 1)
        (progn
          (setq Num# 1 List@ (cons (nth 0 Prefixes@) (append Prefixes@ (list (last Prefixes@)))))
          (repeat (length Prefixes@)
            (setq Compare$ (strcat (nth Num# List@) "*"))
            (if (and (wcmatch (nth (1- Num#) List@) Compare$)(wcmatch (nth (1+ Num#) List@) Compare$))
              (setq Prefixes@ (vl-remove (nth Num# List@) Prefixes@))
            );if
            (setq Num# (1+ Num#))
          );repeat
        );progn
      );if
      (setq SortLenghts@ (reverse (number_sort (mapcar 'strlen Prefixes@))))
      (setq List@ Prefixes@)
      (foreach Num# SortLenghts@
        (setq First t)
        (foreach Str$ List@
          (if (and (= (strlen Str$) Num#) First)
            (setq First nil
                  List@ (vl-remove Str$ List@)
                  PrefixSort@ (append PrefixSort@ (list Str$))
            );setq
          );if
        );foreach
      );foreach
      (setq Prefixes@ (mapcar 'list PrefixSort@))
      (setq List@ AlphaSort@ Num# 0)
      (foreach Prefix$ PrefixSort@
        (setq Compare$ (strcat Prefix$ "#*")
              PrefixList@ (nth Num# Prefixes@)
              First t
        );setq
        (foreach Str$ List@
          (if (wcmatch Str$ Compare$)
            (progn
              (if First
                (setq PrefixList@ (append PrefixList@ (list (vl-position Str$ AlphaSort@)))
                      First nil
                );setq
              );if
              (setq List@ (vl-remove Str$ List@)
                    Str$ (substr Str$ (1+ (strlen Prefix$)))
                    PrefixList@ (append PrefixList@ (list Str$))
              );setq
            );if
          );if
        );foreach
        (setq Prefixes@ (change_nth Num# PrefixList@ Prefixes@))
        (setq Num# (1+ Num#))
      );foreach
      (foreach PrefixList@ Prefixes@
        (setq NumStrings@ (cddr PrefixList@)
              NumSort@ (number_sort (mapcar 'atoi NumStrings@))
              List@ nil
        );setq
        (foreach Num# NumSort@
          (setq Loop t Cnt# 0)
          (while Loop
            (setq Str$ (nth Cnt# NumStrings@))
            (if (= (atoi Str$) Num#)
              (setq NumStrings@ (delete_nth Cnt# NumStrings@)
                    Str$ (strcat (nth 0 PrefixList@) Str$)
                    List@ (append List@ (list Str$))
                    Loop nil
              );setq
            );if
            (setq Cnt# (1+ Cnt#))
          );while
        );foreach
        (setq Num# (nth 1 PrefixList@) SortList@ Original@)
        (foreach Str$ List@
          (setq Str$ (nth (vl-position Str$ AlphaSort@) Original@))
          (setq SortList@ (change_nth Num# Str$ SortList@))
          (setq Num# (1+ Num#))
        );foreach
        (setq Original@ SortList@)
      );foreach
    );progn
  );if
  (foreach Str$ AlphaSort@
    (if (wcmatch (substr Str$ 1 1) "#")
      (setq NumStrings@ (append NumStrings@ (list Str$)))
    );if
  );foreach
  (if NumStrings@
    (progn
      (setq NumSort@ (number_sort (mapcar 'atoi NumStrings@))
            List@ nil
      );setq
      (foreach Num# NumSort@
        (setq Loop t Cnt# 0)
        (while Loop
          (setq Str$ (nth Cnt# NumStrings@))
          (if (= (atoi Str$) Num#)
            (setq NumStrings@ (delete_nth Cnt# NumStrings@)
                  List@ (append List@ (list Str$))
                  Loop nil
            );setq
          );if
          (setq Cnt# (1+ Cnt#))
        );while
      );foreach
      (setq Num# 0 SortList@ Original@)
      (foreach Str$ List@
        (setq Str$ (nth (vl-position Str$ AlphaSort@) Original@))
        (setq SortList@ (change_nth Num# Str$ SortList@))
        (setq Num# (1+ Num#))
      );foreach
      (setq Original@ SortList@)
    );progn
  );if
  Original@
);defun win_sort
;-------------------------------------------------------------------------------
; number_sort - Sorts list of numbers
; Arguments: 1
;   List@ = List of numbers
; Returns: List of sorted numbers
;-------------------------------------------------------------------------------
(defun number_sort (List@ / High~ Item~ List1@ List2@ Low~ NewList@ Passed Swap~)
  (setq Passed t)
  (if (= (type List@) 'LIST)
    (foreach Item~ List@ (if (not (numberp Item~)) (setq Passed nil)))
    (setq Passed nil)
  );if
  (if (not Passed)
    (progn (princ "\nUsage: (number_sort <list of numbers>)") (exit))
  );if
  (repeat (/ (length List@) 2)
    (setq Low~ (car List@) High~ nil NewList@ nil)
    (foreach Item~ (cdr List@)
      (and (< Item~ Low~) (setq Swap~ Low~ Low~ Item~ Item~ Swap~))
      (and (> Item~ High~) (setq Swap~ High~ High~ Item~ Item~ Swap~))
      (setq NewList@ (cons Item~ NewList@))
    );foreach
    (setq List1@ (cons Low~ List1@) List2@ (cons High~ List2@) List@ (cdr (reverse NewList@)))
  );repeat
  (append (reverse List1@) List@ List2@)
);defun number_sort
;-------------------------------------------------------------------------------
; Change_nth - Changes the nth item in a list with a new item value.
; Arguments: 3
;   Num# = Nth number in list to change
;   Value = New item value to change to
;   OldList@ = List to change item value
; Returns: A list with the nth item value changed.
;-------------------------------------------------------------------------------
(defun Change_nth (Num# Value OldList@)
  (if (<= 0 Num# (1- (length OldList@)))
    (if (> Num# 0)
      (cons (car OldList@) (Change_nth (1- Num#) Value (cdr OldList@)))
      (cons Value (cdr OldList@))
    );if
    OldList@
  );if
);defun Change_nth
;-------------------------------------------------------------------------------
; Delete_nth - Deletes the nth item from a list.
; Arguments: 2
;   Num# = Nth number in list to delete
;   OldList@ = List to delete the nth item
; Returns: A list with the nth item deleted.
;-------------------------------------------------------------------------------
(defun Delete_nth (Num# OldList@)
  (setq Num# (1+ Num#))
  (vl-remove-if '(lambda (x) (zerop (setq Num# (1- Num#)))) OldList@)
);defun Delete_nth
;-------------------------------------------------------------------------------
; c:Win_Demo - Demo to test the Win_Sort functions.
; The following example shows the difference.
; Original list:    Win_Sort list:
; PN-37-10r3.dwg    PN-37-1r1.dwg
; PN-37-1r1.dwg     PN-37-5r2.dwg
; PN-37-50r4.dwg    PN-37-10r3.dwg
; PN-37-5r2.dwg     PN-37-50r4.dwg
;-------------------------------------------------------------------------------
(defun c:Win_Demo (/ Filename$ OriginalList@ PathFilename$ WinSortList@)
  (princ "\nSelect a drawing in a folder for Folder name:")(princ)
  (if (not *LastFolder$)
    (setq *LastFolder$ (getvar "DWGPREFIX"))
  );if
  (if (setq PathFilename$ (getfiled " Select a drawing in a folder for Folder name" *LastFolder$ "dwg" 2))
    (setq *LastFolder$ (strcat (vl-filename-directory PathFilename$) "\\"))
    (exit)
  );if
  (textscr)
  (princ (strcat "\n" *LastFolder$))
  (setq OriginalList@ (vl-directory-files *LastFolder$ "*.dwg" 1))
  (princ (strcat "\n" (chr 160) "\nOriginal list:"))
  (foreach Filename$ OriginalList@
    (princ "\n")(princ Filename$)
  );foreach
  (setq WinSortList@ (win_sort (vl-directory-files *LastFolder$ "*.dwg" 1)))
  (princ (strcat "\n" (chr 160) "\nWin_Sort list:"))
  (foreach Filename$ WinSortList@
    (princ "\n")(princ Filename$)
  );foreach
  (princ)
);defun c:Win_Demo
;-------------------------------------------------------------------------------
(princ);End of Win_Sort.lsp