Author Topic: Multi Sort  (Read 6482 times)

0 Members and 1 Guest are viewing this topic.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10366
Multi Sort
« on: August 25, 2005, 05:22:48 PM »
I am working on another sort routine & wanted to see if anyone has already skinned this cat.

Given this
("E-1" "A-2" "E-10" "A-10" "E-2" "A-1" "A-1A" "oops" "~nonplot" "33")
This routine returns this
("A-1A" "A-1" "A-2" "A-10" "E-1" "E-2" "E-10" "oops" "~nonplot")
Your regular sort (vl-sort lst '<) returns this
("33" "A-1" "A-10" "A-1A" "A-2" "E-1" "E-10" "E-2" "oops" "~nonplot")
as you can see the A-10 is out of place for tab names
but in my routine the "A-1A" "A-1" are returned in an arbitrary order and an additional sort
should be made to put them in the correct order. I did not get that far yet.

Logic:
Make a list with sub list of prefix, number, original  ie (("A-" 1 "A-1") ("A-" 1 "A-1A")...)
Sort the list by the prefix
Then sort the groups of prefixes by the number
Then sort the identical numbers by the original **  not in my routine
Then return only a list of the original

So, anyone have a better way? Or suggestions?


Code: [Select]
;; ---------------------------------------------------------------------------
;; Function: Num_sort
;; Purpose : sort list of strings by the prefix then the first numbers found
;; AUTHOR  : Charles Alan Butler
;; Version : 2.05  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   S O R T  R O U T I N E         
  ;;*********************************************************

  (vl-load-com)
  (setq newlst (mapcar 'vl-string->list tablst))
  (setq newlst (group newlst))

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

     ))
    newlst
  )


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


  (setq newlst (mapcar 'delist newlst)) ;  remove grouping
  ;;  convert back to string
  (setq newlst (mapcar (function(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 (function(lambda (e1 e2) (< (cdr e1) (cdr e2))))))
  ;;  reduce list to original items
  (setq tablst (mapcar 'car tablst))

  tablst
) ; end defun
;;==========================================================================
;;                     E N D   S O R T   R O U T I N E                     
;;==========================================================================

Code: [Select]
_$ (num_Sort '("PC 6.11" "PC 5.02" "PC 5.01" "PC 6.01" "PC 5.10"))
("PC 5.01" "PC 5.02" "PC 5.10" "PC 6.01" "PC 6.11")
_$ (num_Sort '("PDU-NT6/2" "PDU-NT5/2" "PDU-NT6/11" "PDU-NT6/1" "PDU-NT5/3"))
("PDU-NT5/2" "PDU-NT5/3" "PDU-NT6/1" "PDU-NT6/2" "PDU-NT6/11")
_$ (num_Sort '("ASTS NT6-01" "ASTS NT5-11" "ASTS NT5-02" "ASTS NT6-11" "ASTS NT5-01"))
("ASTS NT5-01" "ASTS NT5-02" "ASTS NT5-11" "ASTS NT6-01" "ASTS NT6-11")
_$ (num_Sort '("TF-NT6-1" "TF-NT5-2" "TF-NT5-1" "TF-NT6-2" "TF-NT8-1" "TF-NT5-11"))
("TF-NT5-1" "TF-NT5-2" "TF-NT5-11" "TF-NT6-1" "TF-NT6-2" "TF-NT8-1")
_$ (num_Sort '("MDB-ST6/11" "MDB-ST5/21" "MDB-ST5/02" "MDB-ST5/11" "MDB-ST5/01" "MDB-ST6/01"))
("MDB-ST5/01" "MDB-ST5/02" "MDB-ST5/11" "MDB-ST5/21" "MDB-ST6/01" "MDB-ST6/11")
« Last Edit: October 16, 2011, 09:40:34 AM by CAB »
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.

Keith™

  • Villiage Idiot
  • Seagull
  • Posts: 16721
  • Superior Stupidity at its best
Multi Sort
« Reply #1 on: August 25, 2005, 05:39:47 PM »
I did see something once upon a time, but I'll have to look and see what I can find.
Proud provider of opinion and arrogance since November 22, 2003 at 09:35:31 am
CadJockey Militia Field Marshal

MP

  • Seagull
  • Posts: 17454
Multi Sort
« Reply #2 on: August 25, 2005, 05:48:31 PM »
Create and sort a parallel index. When my headache comes down a couple notches I'll look into providing some sample code.

Until then some somwhat related threads: here, here  ...
\|// Set goal. Experiment tirelessly until
|Oo| practice has become expertise.  Loop.
|- | LinkedIn | Dropbox

CAB

  • Global Moderator
  • Seagull
  • Posts: 10366
Multi Sort
« Reply #3 on: August 25, 2005, 06:48:15 PM »
Thanks guys, I updated the code & it does return:
("A-1" "A-1B" "A-1C" "A-1A" "A-2" "A-10" "E-1A" "E-1B" "E-10" "E-12")

So the missing link is to sort on the suffix within groups of matching numbers.
Or simply sort on the original text but within matching number groups.

The desired result of course is:
("A-1" "A-1A" "A-1B" "A-1C" "A-2" "A-10" "E-1A" "E-1B" "E-10" "E-12")
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.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10366
Multi Sort
« Reply #4 on: August 27, 2005, 09:50:41 AM »
OK this is what I have come up with.
Comments and attempts to optimize are welcome.
sorts this:
("A-1B" "A-1" "A-1A" "A-1C" "A-10" "A-2" "D-1" "D-1A" "E-1B" "E-1A" "E-10" "E-12")

to this:
("A-1" "A-1A" "A-1B" "A-1C" "A-2" "A-10" "D-1" "D-1A" "E-1A" "E-1B" "E-10" "E-12")

I have not done testing to catch errors, but will.


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

;;........................................................................
(defun Num_Sort (tablst / tab ptr len loop tmp tmp2 sub lst
                 vl-sort-it sort2 group_on2)

  (defun vl-sort-it (lst func)
    (mapcar '(lambda (x) (nth x lst)) (vl-sort-i lst func))
  )

  ;;........................................................................
  (defun sort2 (tmp2 sub)
    (setq tmp2 (append
                 (vl-sort-it sub '(lambda (e1 e2) (< (cadr e1) (cadr e2))))
                 tmp2
               )
    )
  )

  ;;........................................................................
  ;; CAB 08/29/05
  ;;  group on the first two elements  A B
  ;;  InpLst is the presorted list ((A B C) (D E F)...)
  (defun group_on2 (InpLst / OutLst tmp grp idx sub)
    ;;  get the first item
    (setq pre (car (nth 0 InpLst))
          grp (nth 1 (nth 0 InpLst))
    )
    (while InpLst
      (if (or (= (length InpLst) 1)
              (/= (setq tmp (nth 1 (nth 0 InpLst))) grp)
              (/= pre (car (nth 0 InpLst)))
          )
        ;;  collect the sub list
        (setq OutLst (cons sub OutLst)
              sub    (list (nth 0 InpLst))
              grp    (nth 1 (nth 0 InpLst))
              pre    (car (nth 0 InpLst))
        )
        ;; build the sub list
        (setq sub (cons (nth 0 InpLst) sub))
      )
      (setq InpLst (cdr InpLst))
    )
    (if sub
      (setq OutLst (cons sub OutLst))
    )
    (reverse OutLst)
  )
  ;;........................................................................


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

  ;;  convert to a list (string) -> (prefix num string)
  (foreach tab tablst
    (setq ptr  1
          len  (strlen tab)
          loop t
    )
    (while loop
      (cond
        ((wcmatch "0123456789" (strcat "*" (substr tab ptr 1) "*"))
         (setq tmp  (cons (list (substr tab 1 (1- ptr))
                                (atof (substr tab ptr))
                                tab
                          )
                          tmp
                    )
               loop nil
         )
        )
        ((> (setq ptr (1+ ptr)) len)
         ;;  no number in string
         (setq tmp  (cons (list tab nil tab) tmp)
               loop nil
         )
        )
      ) ; end cond stmt
    )
  )

  ;;  sort on the prefix
  (setq tmp (vl-sort-it tmp '(lambda (e1 e2) (< (car e1) (car e2)))))

  ;; Do a number sort on each group of matching prefex
  (setq idx (length tmp))
  (while (> (setq idx (1- idx)) -1)
    (cond
      ((not sub)
       (setq sub (list (nth idx tmp))
             str (car (nth idx tmp))
       )
      )
      ((= (car (nth idx tmp)) str) ; still in the group
       (setq sub (cons (nth idx tmp) sub))
      )
    ) ; end cond stmt

    (if (= idx 0) ; end of list
      (progn
        (setq tmp2 (sort2 tmp2 sub))
        (if (/= (car (nth idx tmp)) str)
          (setq tmp2 (append (list (nth idx tmp)) tmp2))
        )
        (setq str (car (nth idx tmp)))
      )
    )

    (if (/= (car (nth idx tmp)) str)
      ;; next group, so sort previous group
      (setq tmp2 (sort2 tmp2 sub)
            sub  (list (nth idx tmp))
            str  (car (nth idx tmp))
      )
    )
  ) ; end while

  ;;--------------------------------------------------------------------
  ;;  group into sub list based on the fist 2 elements
  (setq tmp2 (group_on2 tmp2))
  ;;--------------------------------------------------------------------


  ;;--------------------------------------------------------------------
  ;;  setp through each sub list & sort on the 3rd
  (setq tmp nil)
  (foreach itm tmp2
    ;;  sort on the 3rd
    (setq tmp
           (cons
             (vl-sort-it itm '(lambda (e1 e2) (< (caddr e1) (caddr e2))))
             tmp
           )
    )
  )
  ;;--------------------------------------------------------------------



  ;;--------------------------------------------------------------------
  ;;  remove the grouping
  (setq tmp2 nil)
  (foreach itm tmp
    (setq tmp1 (reverse itm))
    (while tmp1
      (setq tmp2 (cons (car tmp1) tmp2)
            tmp1 (cdr tmp1)
      )
    )
  )
  ;;--------------------------------------------------------------------


  ;;--------------------------------------------------------------------
  ;;  reduce list to original items
  (setq lst (mapcar 'caddr tmp2))
  ;;--------------------------------------------------------------------


  (princ)
  lst
) ; end defun
;;==========================================================================










Code: [Select]
(defun c:test (/ lst)
  (setq lst
         '("A-1B" "A-1" "A-1A" "A-1C" "A-10" "A-2" "D-1" "D-1A" "E-1B" "E-1A"
           "E-10" "E-12"
          )
  )
  (num_sort lst)
  ;;  returns ("A-1" "A-1A" "A-1B" "A-1C" "A-2" "A-10" "D-1" "D-1A" "E-1A" "E-1B"
  ;;            "E-10" "E-12")
)
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.

MP

  • Seagull
  • Posts: 17454
Multi Sort
« Reply #5 on: August 27, 2005, 10:22:08 AM »
Quick thoughts.

Given this --

Code: [Select]
(

    (lambda ( / raw sortIndex sorted )

        (setq raw
           '(
                "D-1A"
                "A-2"
                "E-12"
                "A-1A"
                "A-10"
                "D-1"
                "A-1B"
                "E-10"
                "A-1"
                "E-1B"
                "A-1C"
                "E-1A"
            )
        )        

        (setq sortIndex
           '(
                "D-01A"
                "A-02"
                "E-12"
                "A-01A"
                "A-10"
                "D-01"
                "A-01B"
                "E-10"
                "A-01"
                "E-01B"
                "A-01C"
                "E-01A"
            )
        )

        (setq sorted
            (vl-sort
                (mapcar 'cons raw sortIndex)
               '(lambda (a b)
                    (<
                        (cdr a)
                        (cdr b)
                    )
                )
            )
        )

        (mapcar 'print
            (mapcar
               'car
                sorted
            )
        )

        (princ)
    )    

)

Which outputs the data sorted correctly (me thinks) --

"A-1"
"A-1A"
"A-1B"
"A-1C"
"A-2"
"A-10"
"D-1"
"D-1A"
"E-1A"
"E-1B"
"E-10"
"E-12"

The challenge is to write a function which will normalize items in a list for sorting (hard coded above in the (setq sortIndex ...) code), and I'd pen that as a seperate function.

Code: [Select]
(defun CreateSortIndex ( lst ) ... )
\|// Set goal. Experiment tirelessly until
|Oo| practice has become expertise.  Loop.
|- | LinkedIn | Dropbox

CAB

  • Global Moderator
  • Seagull
  • Posts: 10366
Multi Sort
« Reply #6 on: August 27, 2005, 11:29:35 AM »
Hey, that's cheating! :D

Seriously though, there are many forms of tab labeling & I was trying to accommodate
as many as I could. This subroutine is for my TabMover routine. It may be larger than it's
parent routine. :)

Here are a few I envisioned (right or wrong)
1 first floor
2 second floor
3 elevations
(setq lst '("5 foundation" "2 second floor" "4 electrical" "1 first floor" "3 elevations"))

A 1
A 2
A 2a
PA
W1
W2
(setq lst '("W2" "PA""A 2"  "A 1" "W1" "A 2a"))

Remember these name do not always reflect the text in the title block.
People do strange stings you know.
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.

MP

  • Seagull
  • Posts: 17454
Multi Sort
« Reply #7 on: August 27, 2005, 03:45:48 PM »
No cheatin' at all mang, it was an illustration. I said:

Quote from: MP
The challenge is to write a function which will normalize items in a list for sorting (hard coded above in the (setq sortIndex ...) code), and I'd pen that as a seperate function.

An example of said function might be ...

Code: [Select]
(defun CreateSortIndex ( lst / isdigit pad tolist main )

    ;;  This function (CreateSortIndex ...) is not optimized, nor generic.
    ;;  It is specific to this discussion and was penned quickly. It has
    ;;  errors, warts and pimples. Proceed accordingly.

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

    (defun pad ( codes code len )
        (while (< (length codes) len)
            (setq codes
                (cons code codes)
            )
        )
        codes
    )

    (defun tolist ( string / codes result )
        (foreach code (reverse (vl-string->list string))
            (cond
                (   (null codes)
                    (setq codes (list code))
                )
                (   (isdigit code)
                    (if (isdigit (car codes))
                        (setq codes (cons code codes))
                        (setq
                            result (cons codes result)
                            codes  (list code)
                        )    
                    )
                )
                (   (if (isdigit (car codes))
                        (setq
                            result (cons codes result)
                            codes  (list code)
                        )    
                        (setq codes (cons code codes))
                    )
                )
            )
        )
        (if codes
            (cons codes result)
            result
        )
    )

    (defun main ( lst / maxlen result )

        (setq maxlen 0)

        (foreach lst (setq result (mapcar 'tolist lst))
            (foreach codes lst
                (if (isdigit (car codes))
                    (setq maxlen
                        (max maxlen
                            (length codes)
                        )
                    )
                )
            )
        )
       
        (mapcar
           '(lambda ( lst )
                (apply 'strcat
                    (mapcar
                       '(lambda ( codes )
                            (vl-list->string
                                (if (isdigit (car codes))
                                    (pad codes 48 maxlen)
                                    codes
                                )
                            )    
                        )
                        lst
                    )
                )
            )
            result
        )        
    )
   
    (main lst)    

)

Now let's try it with CAB's data ...

Code: [Select]
(   (lambda ( / raw )

        (setq raw
           '(
                "D-1A"
                "A-2"
                "E-12"
                "A-1A"
                "A-10"
                "D-1"
                "A-1B"
                "E-10"
                "A-1"
                "E-1B"
                "A-1C"
                "E-1A"
            )
        )      

        (mapcar 'print
            (mapcar 'car
                (vl-sort
                    (mapcar 'cons
                        raw
                        (CreateSortIndex raw)
                    )
                   '(lambda (a b)
                        (<
                            (cdr a)
                            (cdr b)
                        )
                    )
                )
            )    
        )

        (princ)
    )
)

Output ...

Code: [Select]
"A-1"
"A-1A"
"A-1B"
"A-1C"
"A-2"
"A-10"
"D-1"
"D-1A"
"E-1A"
"E-1B"
"E-10"
"E-12"

:P

Bonus points: What is the most obvious inefficiency the CreateSortIndex function sports?

Tick ... tick ... tick ...
\|// Set goal. Experiment tirelessly until
|Oo| practice has become expertise.  Loop.
|- | LinkedIn | Dropbox

CAB

  • Global Moderator
  • Seagull
  • Posts: 10366
Multi Sort
« Reply #8 on: August 27, 2005, 06:50:09 PM »
Well is this a test :)

I'm busy doing Honey Do's so I'll get back to you. Stop the clock...

You've just about mapcared me into oblivion. :shock:

Efficiency is the last thing I'd be worried about.
But I'll see if I can sort it out, couldn't resist. 8)

Later...


PS works well.
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.

MP

  • Seagull
  • Posts: 17454
Multi Sort
« Reply #9 on: August 27, 2005, 07:52:38 PM »
Quote from: CAB
You've just about mapcared me into oblivion. :shock:

Dang, I shouldn't have used the vertical coding style.

:oops:
\|// Set goal. Experiment tirelessly until
|Oo| practice has become expertise.  Loop.
|- | LinkedIn | Dropbox

CAB

  • Global Moderator
  • Seagull
  • Posts: 10366
Multi Sort
« Reply #10 on: August 28, 2005, 08:18:42 PM »
OK, after much head scratching this is what I came up with:

Pseudo Code
Starting with a list of strings
Convert each string into ascii code lists
Group codes in the list into letters & numbers
Test all number list to find the longest one
Pad out the shorter number list with leading zeros
Convert the ascii list back to strings & recombine them
Combine the new list with the original list & sort on the new elements
Remove the new elements returning the original elements in a sorted list
Print each element in the sorted list


As for inefficiencies, your code was 2.5 time faster than mine  :shock: when I removed
your 'Print' of the list. I though perhaps MaxLen could have been acquired
in the "tolist" function. Was that it. :?

commented code, best I could that is...:)
Code: [Select]
(defun CreateSortIndex (lst / isdigit pad tolist main)

  ;;  This function (CreateSortIndex ...) is not optimized, nor generic.
  ;;  It is specific to this discussion and was penned quickly. It has
  ;;  errors, warts and pimples. Proceed accordingly.

  ;; returns True is ascii code is a number 0-9
  (defun isdigit (code)
    (< 47 code 58)
  )

  ;;  add code to the list if the list is too small
  ;;  (pad '(50) 48 2) -> (48 50)
  (defun pad (codes code len)
    (while (< (length codes) len)
      (setq codes (cons code codes))
    )
    codes
  )


  ;;  Process a string ex "D-1A" and return the ascii values
  ;;  in a list of seperate list if a number is present
  ;;  ex "D-1A" -> ((68 45) (49)  (65))
  ;;  ex "E-12" -> ((69 45) (49 50))
  (defun tolist (string / codes result)
    (foreach code (reverse (vl-string->list string)) ; "D-1A" -> (68 45 49 65) reversed
      (cond
        ;; cond 1
        ((null codes) ; first time through
         (setq codes (list code)) ; put something in codes, it is a temp list
        )

        ;; cond 2
        ((isdigit code) ; ok it's a number
         (if (isdigit (car codes)) ; if already got a number
           (setq codes (cons code codes)) ; keep collecting them
           ;;  else not a num so make previous nums into a seperate list
           (setq
             result (cons codes result) ; collect it, this is the return list
             codes  (list code) ; reset codes
           )
         )
        )

        ;; cond 3   this is executed if 1 & 2 fail
        ;; this time code is not a number
        ((if (isdigit (car codes)) ; got a number list started so
           (setq ;  end the collection of number list & start a letters list
             result (cons codes result) ; collect it, this is the return list
             codes  (list code) ; reset codes
           )
           ;;  else more letters, keep collecting
           (setq codes (cons code codes))
         )
        )
      ) ;end cond stmt
    ) ; end foreach
    (if codes ; the temp list is not empty so collect it
      (cons codes result) ; return all collected
      result ; return all collected
    )
  )

  ;;  main
  (defun main (lst / maxlen result)

    (setq maxlen 0) ; the greatest number of consecutive digits in numeric string


    ;;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
    ;;  step through each sublist looking for the longest 'number list'
    ;;  & if a number is found get the max length

    ;;  set 'result' as follows
    ;;  (mapcar 'tolist lst)  feed each item in the list to 'tolist
    ;;  see 'tolist for explination of return value
    ;;  (mapcar 'tolist lst) -> (((68 45) (49) (65)) ((65 45) (50)) ...)
   
    (foreach lst (setq result (mapcar 'tolist lst))
      (foreach codes lst
        (if (isdigit (car codes))
          (setq maxlen (max maxlen (length codes)))
        )
      )
    )
    ;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

   

    ;;  convert the ascii list 'result' back to a string after padding out
    ;;  the numeric portion to the number of digits = maxlen
    (mapcar
      '(lambda (lst)
         (apply 'strcat  ; combine into a string
                (mapcar
                  '(lambda (codes)
                     (vl-list->string
                       (if (isdigit (car codes)); if a number
                         (pad codes 48 maxlen) ; do the pading
                         codes
                       )
                     )
                   )
                  lst
                )
         )
       )
      result
    )
  ) ; end main

  (main lst) ;  this kicks it off and returns the padded list
  ;; '("D-01A" "A-02" "E-12" "A-01A" "A-10" "D-01" "A-01B" "E-10" "A-01" "E-01B" "A-01C" "E-01A")

) ; end of CreateSortIndex


;;=========================================================================


;;  Start processing here
  ((lambda (/ raw)

 (setq raw  '("D-1A" "A-2" "E-12" "A-1A" "A-10" "D-1" "A-1B" "E-10" "A-1" "E-1B" "A-1C" "E-1A"))


     (mapcar 'print ; display each item in the list
             (mapcar 'car ; return the first element if the list
                     (vl-sort ;  sort the list based on 2nd element
                       ;; this creates a dotted pair list (original . padded)
                       (mapcar 'cons raw (CreateSortIndex raw))
                       '(lambda (a b) (< (cdr a) (cdr b)))
                     )
             )
     )

     (princ)
   )
)
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.

MP

  • Seagull
  • Posts: 17454
Multi Sort
« Reply #11 on: August 29, 2005, 07:39:10 AM »
Excellent analysy Alan, I'm impressed you took the time to break it down. I massaged it a bit:

MakeSortIndex pseudo code
• function expects to be passed a list of alpha numeric strings
• convert each string to a list of ascii codes (hereafter referred to as codes)
• group codes in each list into sublists of digits and non digits
• find the length of the longest digit sublist, put value in maxlen
• pad each digit sublist with leading zeros so that the sublist length equals the maxlen value *

Option A
• convert each sublist to substrings and strcat the substrings to one string

Option B (should be faster, only 1 strcat call per list item, append is faster than strcat)
• append each list of sublists to return one code list per original list item
• convert each code list to a string

Using the MakeSortIndex
• combine the new list with the original list
• sort, using elements in the new list
• discard the new list elements

Here's a version that uses Option B:

Code: [Select]
(defun CreateSortIndex ( lst / isdigit pad tolist main )

    ;;  This function (CreateSortIndex ...) is not optimized,
    ;;  nor generic. It is specific to this discussion and was
    ;;  penned quickly. It has errors, warts and pimples.
    ;;
    ;;  Proceed accordingly.

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

    (defun pad ( codes code len )
        (while (< (length codes) len)
            (setq codes
                (cons code codes)
            )
        )
        codes
    )

    (defun tolist ( string / codes result )
        (foreach code (reverse (vl-string->list string))
            (cond
                (   (null codes)
                    (setq codes (list code))
                )
                (   (isdigit code)
                    (if (isdigit (car codes))
                        (setq codes (cons code codes))
                        (setq
                            result (cons codes result)
                            codes  (list code)
                        )  
                    )
                )
                (   (if (isdigit (car codes))
                        (setq
                            result (cons codes result)
                            codes  (list code)
                        )  
                        (setq codes (cons code codes))
                    )
                )
            )
        )
        (if codes
            (cons codes result)
            result
        )
    )

    (defun main ( lst / maxlen result )

        (setq maxlen 0)

        (foreach lst (setq result (mapcar 'tolist lst))
            (foreach codes lst
                (if (isdigit (car codes))
                    (setq maxlen
                        (max maxlen
                            (length codes)
                        )
                    )
                )
            )
        )
       
        (mapcar
           '(lambda ( lst )
                (vl-list->string
                    (apply 'append
                        (mapcar
                           '(lambda ( codes )
                                (if (isdigit (car codes))
                                    (pad codes 48 maxlen)
                                    codes
                                )
                            )
                            lst
                        )
                    )
                )    
            )
            result
        )      
    )
   
    (main lst)

)

Only 2% faster. :|

PS: One of the inefficiencies is marked with the red asterisk (*) above. "But", you say "that's how it works". True that, but if it performed more analysis it would also consider position. However, my guess was that the amount of overhead required to do the position analysis outweighed the benefits of position context padding.

But if one could write a fast and furious position analyser, well ...

Thanks for letting me play in your thread Alan, was fun. :)
\|// Set goal. Experiment tirelessly until
|Oo| practice has become expertise.  Loop.
|- | LinkedIn | Dropbox

CAB

  • Global Moderator
  • Seagull
  • Posts: 10366
Multi Sort
« Reply #12 on: August 29, 2005, 08:20:48 AM »
Michael you can play in my sand box anytime.
If you took the time to write it, I felt I should take the time to understand it.
Although it took me a lot longer. :) I'm trying to catch up by it is difficult be cause
you are much taller. 8)

Thanks for the clear explanation.
This is what I had in mind for the Mexlen situation, but may not be any more efficient.
Ans I think you prefer to separate rather than combine procedures.

Code: [Select]
   (defun tolist ( string / codes result Maxlen)
      (setq maxlen 0)
        (foreach code (reverse (vl-string->list string))
            (cond
                (   (null codes)
                    (setq codes (list code))
                )
                (   (isdigit code)
                    (if (isdigit (car codes))
                        (setq codes (cons code codes))
                        (setq
                            maxlen (max maxlen (length codes))
                            result (cons codes result)
                            codes  (list code)
                        )    
                    )
                )
                (   (if (isdigit (car codes))
                        (setq
                            maxlen (max maxlen (length codes))
                            result (cons codes result)
                            codes  (list code)
                        )    
                        (setq codes (cons code codes))
                    )
                )
            )
        )
        (if codes
            (setq
              maxlen (if (isdigit (car codes))
                       (max maxlen (length codes))
                       maxlen
                     )
              result (cons (cons codes result) maxlen)
            )    
            (cond result maxlen)
        )
    )
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.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10366
Multi Sort
« Reply #13 on: August 29, 2005, 08:45:03 AM »
I tried to write a mapcar version of your maxlen foreach loop
just to see if I could do it. Looks like it works.


Code: [Select]
(setq result (mapcar 'tolist lst))
(setq maxlen 0)
(mapcar
  '(lambda (sub)
    (mapcar
      '(lambda (codes)
        (if (isdigit (car codes))
          (setq maxlen
                 (max maxlen
                      (length codes)
                 )
          )
        )
      )
      sub
    )

  )
  result
)
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.

MP

  • Seagull
  • Posts: 17454
Multi Sort
« Reply #14 on: August 29, 2005, 10:48:56 AM »
I'll have a boo at this at lunch Alan. :)
\|// Set goal. Experiment tirelessly until
|Oo| practice has become expertise.  Loop.
|- | LinkedIn | Dropbox