Author Topic: Multi Sort  (Read 6488 times)

0 Members and 1 Guest are viewing this topic.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10366
Multi Sort
« Reply #15 on: August 29, 2005, 12:06:14 PM »
OK as an exercise, here is my feeble attempt at rewriting my sort, stealing much of your code. :)
Still slower than yours but only slightly.

Code: [Select]
;; ---------------------------------------------------------------------------
;; Function: tab_sort
;; Purpose : sort list of strings by the prefix then the first numbers found
;; AUTHOR  : Charles Alan Butler
;; Version : 2.0  08/29/05
;; Params  : tablst:    list of strings to sort
;; Returns : sorted list
;; ---------------------------------------------------------------------------

(defun Num_Sort (tablst / newlst result tmp code codes padlen sub x
                 isdigit delist group )


  ;;........................................................................
  (defun isdigit (code) (< 47 code 58))

  ;;........................................................................
  (defun delist (lst / delst)
    (defun delst (lst / 1-list a)
      (while lst
        (if (listp lst)
          (if (and (listp (setq a (car lst))) a)
            (setq 1-list (append (delst a) 1-list))
            (setq 1-list (cons a 1-list))
          )
          (setq 1-list (cons lst 1-list))
        )
        (setq lst (cond ((listp lst) (cdr lst))))
      )
      1-list
    )
    (reverse (delst lst))
  )


  ;;........................................................................
  ;; group ascii into numbers & non numbers
  (defun group (newlst / newlst2 tab code result grplst tmplst)
    (foreach tab newlst
      (setq tmplst nil
            result nil
      )
      (foreach code (reverse tab)
        (cond
          ((null tmplst)
           (setq tmplst (list code))
          )
          ((isdigit code)
           (if (isdigit (car tmplst))
             (setq tmplst (cons code tmplst))
             (setq
               result (cons tmplst result)
               tmplst (list code)
             )
           )
          )
          ((if (isdigit (car tmplst))
             (setq
               result (cons tmplst result)
               tmplst (list code)
             )
             (setq tmplst (cons code tmplst))
           )
          )
        )
      )
      (if tmplst
        (setq result (cons tmplst result))
      )
      (setq newlst2 (cons result newlst2))
    )
  )




  ;;************************************************
  ;;        S T A R T   O F   R O U T I N E        
  ;;************************************************

  (vl-load-com)

  (setq newlst (mapcar
                 '(lambda (x)
                    (vl-string->list x)
                  )
                 tablst
               )
  )

  (setq newlst (group newlst))

  ;;  set max length of numerical sequience
  (setq padlen 0)
  (mapcar
    '(lambda (sub)
       (mapcar
         '(lambda (codes)
            (if (isdigit (car codes))
              (setq padlen
                     (max padlen
                          (length codes)
                     )
              )
            )
          )
         sub
       )

     )
    newlst
  )



  ;; pad numerical list
  (setq newlst
         (mapcar
           '(lambda (sub)
              (mapcar
                '(lambda (x)
                   (if (isdigit (car x))
                     (progn
                       (while (< (length x) padlen)
                         (setq x (cons 48 x)
                         )
                       )
                       x
                     )
                     x
                   )
                 )
                sub
              )
            )
           newlst
         )
  )



  ;;  remove grouping
  (setq newlst (mapcar 'delist newlst))

  ;;  convert back to string
  (setq newlst (mapcar
                 '(lambda (x)
                    (vl-list->string x)
                  )
                 newlst
               )
  )


  ;;  combine new & old list
  (setq tablst (mapcar 'cons tablst (reverse newlst)))

  ;;  sort on new list
  (setq tablst (vl-sort tablst '(lambda (e1 e2) (< (cdr e1) (cdr e2)))))

  ;;--------------------------------------------------------------------
  ;;  reduce list to original items
  (setq tablst (mapcar 'car tablst))
  ;;--------------------------------------------------------------------

  tablst
) ; end defun
;;==========================================================================
I've reached the age where the happy hour is a nap. ()
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.