Topic: A linear equation set solver, thank to Evgeniy's help.

[qjchen]

My original meaning is to test a matrix inverse function.
After Evgeniy's convert function, now it can solve some linear equation set:)
Sorry for the tedious code

Code: [Select]

;;; ===================================================;
;;; some the following code are writen by   QJCHEN     ;
;;; Purpose: A equation solver function                ;
;;; Great thanks to ElpanovEvgeniy at theswamp,        ;
;;;        his function to seperate the variable and   ;
;;;        the number give me great help               ;
;;; Usage: select some texts like 1x+2y+3z+0a-5b+6d=5  ;
;;;        Then if the equation set has solution,      ;
;;;        it will give out                            ;
;;;        else, it will get error                     ;
;;; Note:  This code is just to test my matrix inverse ;
;;;        function, I find it is not so convenient to ;
;;;        do matrix operation in Lisp                 ;
;;; 2006.11.11                                         ;
;;; ===================================================;

(defun c:test (/ pub rlst lalllst c h)
  (setq pub (gettext))


  (getlst pub)

  (result)


)

;;; ===================================================
;;; Function to get text and convert it to new lst    ;
;;; ===================================================
(defun gettext (/ sstext n i obj ent text res lstall lsttext)
  (setq sstext (ssget))
  (if sstext
    (progn
      (setq n (sslength sstext)
            i 0
      )
      (repeat n
        (setq obj (ssname sstext i))
        (setq ent (entget obj))

        (setq text (cdr (assoc 1 ent))
              h    (cdr (assoc 40 ent))
        )
        (setq lsttext (formula->list_01 (list text)))
        (setq lstall (append
                       lstall
                       (list lsttext)
                     )
        )
        (setq res lstall)
        (setq i (1+ i))
      )
    )
  )
  res
)

;;; ===================================================
;;; Function to deal with the new lst and get the     ;
;;;          left and right matrix                    ;
;;; ===================================================
(defun getlst (pub / x y llst)
  (setq c nil)
  (foreach x pub
    (foreach y x
      (setq c (append
                c
                (list (car y))
              )
      )
    )
  )
  (setq c (STD-REMOVE-DUPLICATES c))
  (setq c (vl-sort c '<))
  (setq rlst nil
        lalllst nil
  )
  (foreach y pub
    (setq llst nil)
    (foreach x c
      (if (= x "=")
        (progn

          (setq rlst (append
                       rlst
                       (list (list (cdr (assoc x y))))
                     )
          )
        )
        (progn
          (if (assoc x y)
            (progn
              (setq llst (append
                           llst
                           (list (cdr (assoc x y)))
                         )
              )
            )
            (setq llst (append
                         llst
                         (list 0.0000)
                       )
            )
          )
        )
      )
    )
    (setq lalllst (append
                    lalllst
                    (list llst)
                  )
    )
  )
)
;;; ===================================================
;;; Function to write down the result                 ;
;;; ===================================================
(defun result (/ str tempstr i x str pp)
  (setq temp (matrix_inversion lalllst))
  (setq temp2 (matrix-mul temp rlst))
  (setq str "")
  (setq tempstr (mapcar
                  '(lambda (x)
                     (rtos (nth 0 x) 2 3)
                   )
                  temp2
                )
  )
  (setq i 1)
  (foreach x tempstr
    (setq str (strcat str (nth i c) "=" x " "))
    (setq i (1+ i))
  )
  (setq pp (getpoint "select a point to place the result:\n"))
  (command "text" pp h 0 str)
)

;;; ===================================================
;;; N*N matrix inverse function  ,by qjchen           ;
;;; ===================================================
(defun matrix_inversion (a     /     nmax  ipiv  indxr indxc n
                         n     i     j     k     l     ll    a-temp
                         temp  big   irow  icol  pivinv
                        )
  (setq nmax 50)
  (setq ipiv (create nmax))
  (setq indxr (create nmax))
  (setq indxc (create nmax))
  (setq n (length a))
  (setq i 1)
  (repeat n
    (setq big 0)
    (setq j 1)
    (repeat n
      (if (/= ([n] ipiv j) 1)
        (progn
          (setq k 1)
          (repeat n
            (if (= ([n] ipiv k) 0)
              (progn
                (if (>= (abs ([n,m] a j k)) big)
                  (progn
                    (setq big ([n,m] a j k))
                    (setq irow j)
                    (setq icol k)
                  )
                  (progn
                    (if (> ([n] ipiv k) 1)
                      (princ "singular matrix")
                    )
                  )
                )
              )
            )
            (setq k (1+ k))
          )
        )
      )
      (setq j (1+ j))
    )
    (setq temp (1+ ([n] ipiv icol)))
    (setq ipiv (std-setnth temp (1- icol) ipiv))
    (if (/= irow icol)
      (progn
        (setq l 1)
        (repeat n
          (setq dum ([n,m] a irow l))

          (setq a-temp ([n,m] a icol l))
          (setq a (qj-setnmth a-temp (1- irow) (1- l) a))
          (setq a (qj-setnmth dum (1- icol) (1- l) a))
          (setq l (1+ l))
        )
      )
    )

    (setq indxr (std-setnth irow (1- i) indxr))
    (setq indxc (std-setnth icol (1- i) indxc))
    (if (= ([n,m] a icol icol) 0)
      (princ "singular matrix, the equations have no solve")
    )
    (setq pivinv (/ 1.0 ([n,m] a icol icol)))
    (setq a (qj-setnmth 1 (1- icol) (1- icol) a))
    (setq l 1)
    (repeat n
      (setq a-temp (* ([n,m] a icol l) pivinv))
      (setq a (qj-setnmth a-temp (1- icol) (1- l) a))
      (setq l (1+ l))
    )
    (setq ll 1)
    (repeat n
      (if (/= ll icol)
        (progn
          (setq dum ([n,m] a ll icol))
          (setq a (qj-setnmth 0.0 (1- ll) (1- icol) a))
          (setq l 1)
          (repeat n
            (setq a-temp (- ([n,m] a ll l) (* dum ([n,m] a icol l))))
            (setq a (qj-setnmth a-temp (1- ll) (1- l) a))
            (setq l (1+ l))
          )
        )
      )
      (setq ll (1+ ll))
    )
    (setq i (1+ i))
  )

  (setq l n)
  (repeat n
    (if (/= ([n] indxr l) ([n] indxc l))
      (progn
        (setq k 1)
        (repeat n
          (setq dum ([n,m] a k ([n] indxr l)))
          (setq a-temp ([n,m] a k ([n] indxc l)))
          (setq a (qj-setnmth a-temp (1- k) (1- ([n] indxr l)) a))
          (setq a (qj-setnmth dum (1- k) (1- ([n] indxc l)) a))
          (setq k (1+ k))
        )
      )
    )
    (setq l (1- l))
  )
  a
)


;;; ===================================================
;;; create a list with m 0.0 element ,by qjchen       ;
;;; ===================================================
(defun create (m / lista)               
  (setq lista nil)
  (repeat m
    (setq lista (append
                  lista
                  (list 0.0)
                )
    )
  )
  lista
)
;;; ===================================================
;;; create a list with m*m  0.0 element ,by qjchen    ;
;;; ===================================================
(defun createm (m / lista listb)
  (setq m 5)
  (setq lista nil)
  (repeat m
    (setq listb nil)
    (repeat m
      (setq listb (append
                    listb
                    (list 0.0)
                  )
      )
    )
    (setq lista (append
                  lista
                  (list listb)
                )
    )
  )
  lista
)
;;; ===================================================
;;; a function that Evgeniy write for me :)           ;
;;; ===================================================
(defun formula->list_01 (lst)
  ;; Version 2
  ;; not use VLA- function...
  ;; Argument - (list "formula string")
  ;; By ElpanovEvgeniy
  ;; For qjchen
  ;; when I have a string of  "3x+5y+7z+5a+7b-9c=0"
  ;; how could I write a function to seperate them to (x . 3) (y . 5)
  ;; ......
  ;; that a dot pair, so the string sequence of the equation solver be
  ;; more
  ;; flexible
  ;; but when I try to use (assoc "X" lst) or (assoc X lst)
  ;; it return nil. maybe I get wrong use of assoc?
  ;; what method will be better to get the "X" 's value-- 3.1
  ;;test:
  ;;(formula->list_01 '("3.1xxa+8xxb+7xxc+5abcd+7ef-9c=0"))
  ;;=>
  ;; '(("xxa" . 3.1) ("xxb" . 8.0) ("xxc" . 7.0) ("abcd" . 5.0) ("ef" .
  ;; 7.0) ("c" . -9.0) ("="
  ;; .
  ;; 0.0))
  (cond
    ((= (cadr lst) "") nil)
    ((not (cdr lst))
     (formula->list_01
       (list
         (list (substr (car lst) 1 1))
         (substr (car lst) 2)
       ) ;_  list
     ) ;_  formula->list_01
    )
    ((and
       (not (cadar lst))
       (WCMATCH (substr (cadr lst) 1 1) "#,.,+,-,")
     ) ;_  and
     (formula->list_01
       (list
         (list (strcat (caar lst) (substr (cadr lst) 1 1)))
         (substr (cadr lst) 2)
       ) ;_  setq
     ) ;_  formula->list_01
    )
    ((= (substr (cadr lst) 1 1) "=")
     (list
       (cons
         (cadar lst)
         (atof (caar lst))
       ) ;_  cons
       (cons "=" (atof (substr (cadr lst) 2)))
     ) ;_  list
    )
    ((WCMATCH (substr (cadr lst) 1 1) "[a-z],[A-Z]")
     (formula->list_01
       (list
         (list
           (caar lst)
           (strcat (if (cadar lst)
                     (cadar lst)
                     ""
                   ) ;_  if
                   (substr (cadr lst) 1 1)
           ) ;_  strcat
         ) ;_  list
         (substr (cadr lst) 2)
       ) ;_  list
     ) ;_  formula->list_01
    )
    (t
     (cons
       (cons
         (cadar lst)
         (atof (caar lst))
       ) ;_  cons
       (formula->list_01
         (cdr lst)
       ) ;_  formula->list_01
     ) ;_  cons
    ) ;_  t
  ) ;_  cond
)


;;; ===================================================
;;; STDLIB func: substitute the nth element of a list ;
;;; ===================================================
(defun std-%setnth (new i lst / fst len)
  (cond
    ((minusp i)
     lst
    )
    ((> i (setq len (length lst)))
     lst
    )
    ((> i (/ len 2))
     (reverse (std-%setnth new (1- (- len i)) (reverse lst)))
    )
    (t
     (append
       (progn
         (setq fst nil)                 ; ; possible vl lsa compiler
                                        ; bug
         (repeat (rem i 4)
           (setq fst (cons (car lst) fst)
                 lst (cdr lst)
           )
         )
         (repeat (/ i 4)
           (setq fst (cons (cadddr lst)
                           (cons (caddr lst)
                                 (cons
                                   (cadr lst)
                                   (cons
                                     (car lst)
                                     fst
                                   )
                                 )
                           )
                     )
                 lst (cddddr lst)
           )
         )
         (reverse fst)
       )
       (if (listp new)
         new
         (list new)
       )
       (cdr lst)
     )
    )
  )
)
(defun std-setnth (new i lst)
  (std-%setnth (list new) i lst)
)

;;; ===================================================
;;; STDLIB func:remove duplicate element of a list    ;
;;; by Serge Pashkov The below mentioned lsa          ;
;;;        compiler bug couldn't be isolated yet.     ;
;;; ===================================================
(defun STD-REMOVE-DUPLICATES (lst / ele new)
  (setq new nil)                        ; possible VL lsa compiler bug
                                        ; (??)
  (foreach ele lst
    (if (not (member ele new))
      (setq new (cons ele new))
    )
  )
  (reverse new)
)

;;; ===================================================
;;; func:substitute the i row j column element        ;
;;;          of a list                            ;
;;; ===================================================

(defun qj-setnmth (new i j lst / listb lista)
  (setq listb lst)
  (setq lista (nth i lst))
  (setq lista (std-setnth new j lista))
  (setq listb (std-setnth lista i listb))
  listb
)

;;; ===================================================
;;; func:get the value of the n row m column element  ;
;;;      of a 2 dimension list                        ;
;;; ===================================================

(defun [n,m] (a n m / i)
  (setq i (nth (1- m) (nth (1- n) a)))
  i
)
;;; ===================================================
;;; func:get the value of the n-th element of a       ;
;;;           1 dimension list                        ;
;;; ===================================================
(defun [n] (a n / i)
  (setq i (nth (1- n) a))
  i
)

;;; ===================================================
;;; func:A function of multiply of two matrix         ;
;;; ===================================================
(defun matrix-mul (m1 m2 / m3 m4 m33 x y)
  (setq m3  nil
        m33 nil
  )

  (setq m4 (mtr m2))
  (foreach x m1
    (setq m33 nil)
    (foreach y m4
      (setq m (apply
                '+
                (mapcar
                  '*
                  x
                  y
                )
              )
      )
      (setq m33 (append
                  m33
                  (list m)
                )
      )


    )
    (setq m3 (append
               m3
               (list m33)
             )
    )


  )
  m3
)
(defun mtr (x)
  (apply
    'mapcar
    (cons 'list x)
  )
)

(princ "\n type TEST to run the equation solver, by qjchen\n")
(princ)





[Mark]

That's cool stuff Chen! Thanks for sharing.

[SomeCallMeDave]

Great work!!    I can't wait to dig into it deeper.  Thanks for this and all your great posts..

[CADaver]

Now that's sweet, Thanks.

[qjchen]

Thank you, Mark, Dave and Cadaver.

I learn a lot from here, and just share a little, I will try to write more, and need your help:)

I use a bad method to write the matrix inverse code, but Evgeniy was using mapcar to write it, I think it will be much beautiful code.

Keep one learing Lisp every day~~~

[ElpanovEvgeniy]

Code: [Select]

(defun c:cce (/ LP LST)
  ;; by ElpanovEvgeniy
  ;; Calculation of the connected equations
  ;; 13.11.2006
  ;; (c:cce)
  (if (setq lst (text-equation-list))
    (progn
      (setq
        lp  (append
              (ACAD_STRLSORT
                (rem-dupl
                  (vl-remove "=" (apply (function append) (mapcar (function car) lst)))
                ) ;_  rem-dupl
              ) ;_  ACAD_STRLSORT
              '("=")
            ) ;_  append
        lst (vl-remove-if
              (function (lambda (x) (vl-every (function zerop) x)))
              (gauss
                (mapcar
                  (function
                    (lambda (x)
                      (mapcar
                        (function
                          (lambda (a)
                            (if (assoc a (cadr x))
                              (cdr (assoc a (cadr x)))
                              0.
                            ) ;_  if
                          ) ;_  lambda
                        ) ;_  function
                        lp
                      ) ;_  list
                    ) ;_  lambda
                  ) ;_  function
                  lst
                ) ;_  mapcar
              ) ;_  gauss
            ) ;_  vl-remove-if
      ) ;_  setq
      (if (= (1- (length (car lst))) (length lst))
        (if (and (= (length (vl-remove-if (function zerop) (last lst))) 1)
                 (not (zerop (last (last lst))))
            ) ;_  and
          (entmakex
            (list
              '(0 . "MTEXT")
              '(100 . "AcDbEntity")
              '(100 . "AcDbMText")
              (cons 10 (getpoint "\nselect a point to place the result:"))
              '(1 . "This set of equations\n has no solutions!")
            ) ;_  list
          ) ;_  entmakex
          (entmakex
            (list
              '(0 . "MTEXT")
              '(100 . "AcDbEntity")
              '(100 . "AcDbMText")
              (cons 10 (getpoint "\nselect a point to place the result:"))
              (cons
                1
                (apply
                  (function strcat)
                  (mapcar
                    (function
                      (lambda (a b)
                        (strcat
                          a
                          "="
                          (rtos (apply (function /) (reverse (vl-remove-if (function zerop) b)))
                                2
                                8
                          ) ;_  rtos
                          "\n"
                        ) ;_  strcat
                      ) ;_  lambda
                    ) ;_  function
                    lp
                    (mapcar
                      (function (lambda (x) (cdr (reverse (cons (last x) x)))))
                      (reverse
                        (gauss
                          (reverse
                            (mapcar (function (lambda (x) (cdr (reverse (cons (last x) x))))) lst)
                          ) ;_  reverse
                        ) ;_  gauss
                      ) ;_  reverse
                    ) ;_  reverse
                  ) ;_  mapcar
                ) ;_  apply
              ) ;_  cons
            ) ;_  list
          ) ;_  entmakex
        ) ;_  if
        (progn
          (setq lst (reverse
                      (mapcar
                        (function
                          (lambda (x)
                            (vl-remove-if
                              (function (lambda (x1) (zerop (cdr x1))))
                              (mapcar (function cons) lp x)
                            ) ;_  vl-remove-if
                          ) ;_  lambda
                        ) ;_  function
                        (mapcar
                          (function (lambda (x) (cdr (reverse (cons (last x) x)))))
                          (reverse
                            (gauss
                              (reverse
                                (mapcar (function (lambda (x) (cdr (reverse (cons (last x) x)))))
                                        lst
                                ) ;_  mapcar
                              ) ;_  reverse
                            ) ;_  gauss
                          ) ;_  reverse
                        ) ;_  mapcar
                      ) ;_  mapcar
                    ) ;_  reverse
          ) ;_  setq
          (if (= 1 (length (last lst)))
            (entmakex
              (list
                '(0 . "MTEXT")
                '(100 . "AcDbEntity")
                '(100 . "AcDbMText")
                (cons 10 (getpoint "\nselect a point to place the result:"))
                '(1 . "This set of equations\n has no solutions!")
              ) ;_  list
            ) ;_  entmakex
            (entmakex
              (list
                '(0 . "MTEXT")
                '(100 . "AcDbEntity")
                '(100 . "AcDbMText")
                (cons 10 (getpoint "\nselect a point to place the result:"))
                (cons
                  1
                  (apply
                    (function strcat)
                    (mapcar
                      (function
                        (lambda (x)
                          (apply
                            (function strcat)
                            (append
                              (mapcar
                                (function
                                  (lambda (a)
                                    (if (= (car a) "=")
                                      (strcat (car a) (rtos (cdr a) 2 8))
                                      (cond
                                        ((equal (cdr a) 1. 1e-8) (car a))
                                        ((equal (cdr a) -1. 1e-8) (strcat "-" (car a)))
                                        ((minusp (cdr a)) (strcat (rtos (cdr a) 2 8) (car a)))
                                        (t (strcat "+" (rtos (cdr a) 2 8) (car a)))
                                      ) ;_  cond
                                    ) ;_  if
                                  ) ;_  lambda
                                ) ;_  function
                                x
                              ) ;_  mapcar
                              '("\n")
                            ) ;_  append
                          ) ;_  apply
                        ) ;_  lambda
                      ) ;_  function
                      (reverse
                        (Simplification-equations
                          (mapcar
                            (function
                              (lambda (x)
                                (append
                                  (list (car x) (last x))
                                  (mapcar
                                    (function (lambda (a) (cons (car a) (- (cdr a)))))
                                    (reverse (cdr (reverse (cdr x))))
                                  ) ;_  mapcar
                                ) ;_  append
                              ) ;_  lambda
                            ) ;_  function
                            lst
                          ) ;_  mapcar
                        ) ;_  Simplification-equations
                      ) ;_  reverse
                    ) ;_  mapcar
                  ) ;_  apply
                ) ;_  cons
              ) ;_  list
            ) ;_  entmakex
          ) ;_  if
        ) ;_  progn
      ) ;_  if
    ) ;_  progn
  ) ;_  if
) ;_  defun
(defun Simplification-equations (l)
  ;; By ElpanovEvgeniy
  ;; Simplification of the connected equations
  ;|
(Simplification-equations '((("C" . 1.0) ("=" . -3.0) ("D" . -1.0))
       (("B" . 1.0) ("=" . -3.0) ("C" . 2.0))
       (("A" .  1.0) ("=" . 4.0) ("B" .  2.0))
      )
)
  ;; =>
'((("C" . 1.0) ("=" . -3.0) ("D" . -1.0))
  (("B" . 1.0) ("=" . -9.0) ("D" . -2.0))
  (("A" . 1.0)  ("=" . -14.0) ("D" .  -4.0))
 )
  |;
  (if (cdr l)
    (cons
      (cons (cons (caaar l) 1.)(mapcar(function(lambda(x)(cons (car x)(/ (cdr x)(cdaar l)))))(cdar l)))
      (Simplification-equations
        (cons
          (cons
            (cons (caaadr l) 1.)
            (cons
              (cons
                "="
                (+ (cdr (assoc "=" (cadr l)))
                   (* (/(cdr (assoc (caaar l) (cadr l)))(cdaar l)) (cdr (assoc "=" (car l))))
                ) ;_  +
              ) ;_  cons
              (mapcar
                (function (lambda (x) (cons (car x) (* (cdr x) (/(cdr (assoc (caaar l) (cadr l)))(cdaar l))))))
                (cddar l)
              ) ;_  mapcar
            ) ;_  cons
          ) ;_  cons
          (cddr l)
        ) ;_  cons
      ) ;_  Simplification-equations
    ) ;_  cons
    (list (cons (cons (caaar l) 1.)(mapcar(function(lambda(x)(cons (car x)(/ (cdr x)(cdaar l)))))(cdar l))))
  ) ;_  if
) ;_  defun
(defun rem-dupl (lst)
  ;; by ElpanovEvgeniy
  ;; Deleting of all identical objects
  ;; (rem-dupl '(1 2 3 2 1))=>(1 2 3)
  (if lst
    (cons (car lst) (rem-dupl (vl-remove (car lst) (cdr lst))))
  ) ;_  if
) ;_  defun
(defun gauss (lst)
  ;; by ElpanovEvgeniy
  ;; Implementation Gaussian elimination
  ;; For text:
  ;  1x+2y+3z=2
  ;  10x+1y+8z=17
  ;  7z+2y=5
  ;; (gauss '((1.0 2.0 3.0 2.0) (10.0 1.0 8.0 17.0) (0.0 2.0 7.0 5.0)))
  ;; =>
  ;; ((1.0 2.0 3.0 2.0) (0.0 -19.0 -22.0 -3.0) (0.0 0.0 4.68421 4.68421))
  ;;(gauss lst)
  (if (car lst)
    (if (zerop (caar lst))
      (if (vl-every (function zerop) (mapcar (function car) lst))
        (if (cdr lst)
          (cons
            (car lst)
            (mapcar
              (function (lambda (x) (cons 0. x)))
              (gauss (mapcar (function cdr) (cdr lst)))
            ) ;_  mapcar
          ) ;_  cons
          lst
        ) ;_  if
        (gauss
          (cons
            (mapcar
              (function +)
              (car lst)
              (car (vl-remove-if (function (lambda (x) (zerop (car x)))) (cdr lst)))
            ) ;_  mapcar
            (cdr lst)
          ) ;_  cons
        ) ;_  gauss
      ) ;_  if
      (cons
        (car lst)
        (mapcar
          (function (lambda (x) (cons 0. x)))
          (gauss
            (mapcar
              (function
                (lambda (x / i)
                  (setq i (/ (car x) (caar lst)))
                  (mapcar
                    (function -)
                    (cdr x)
                    (mapcar (function (lambda (x1) (* x1 i))) (cdar lst))
                  ) ;_  mapcar
                ) ;_  lambda
              ) ;_  function
              (cdr lst)
            ) ;_  mapcar
          ) ;_  test
        ) ;_  mapcar
      ) ;_  cons
    ) ;_  if
  ) ;_  if
) ;_  defun
(defun text-equation-list (/ s)
  ;; By ElpanovEvgeniy
  ;; select text equation and create list

  ;; For text:
  ;  1x+2y+3z=2
  ;  10x+1y+8z=17
  ;  7z+2y=5
  ;; (text-equation-list)
  ;; =>
  ;|'((("X" "Y" "Z" "=") (("X" . 1.0) ("Y" . 2.0) ("Z" . 3.0) ("=" . 2.0)))
       (("X" "Y" "Z" "=") (("X" . 10.0) ("Y" . 1.0) ("Z" . 8.0) ("=" . 17.0)))
       (("Z" "Y" "=") (("Z" . 7.0) ("Y" . 2.0) ("=" . 5.0)))
     )|;
  (if (setq s (ssget '((0 . "TEXT"))))
    (mapcar
      (function
        (lambda (str)
          (setq
            str (mapcar
                  (function cons)
                  (mapcar
                    (function VL-PRINC-TO-STRING)
                    (read
                      (strcat
                        "("
                        (VL-STRING-TRANSLATE
                          "0123456789.=+-"
                          "              "
                          str
                        ) ;_  VL-STRING-TRANSLATE
                        "=)"
                      ) ;_  strcat
                    ) ;_  read
                  ) ;_  mapcar
                  (mapcar
                    (function FLOAT)
                    (subst
                      -1
                      '-
                      (subst
                        1
                        '+
                        (read
                          (strcat
                            "("
                            (VL-STRING-TRANSLATE
                              "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ="
                              "                                                     "
                              (cond
                                ((WCMATCH (substr str 1 1) "[a-z],[A-Z]") (strcat "1" str))
                                ((WCMATCH (substr str 1 2) "-[a-z],-[A-Z]")
                                 (strcat "-1" (substr str 2))
                                )
                                (t str)
                              ) ;_  cond
                            ) ;_  VL-STRING-TRANSLATE
                            ")"
                          ) ;_  strcat
                        ) ;_  read
                      ) ;_  subst
                    ) ;_  subst
                  ) ;_  mapcar
                ) ;_  mapcar
          ) ;_  setq
          (list (mapcar (function car) str) str)
        ) ;_  lambda
      ) ;_  function
      (mapcar
        (function (lambda (x) (cdr (assoc 1 (entget x)))))
        (vl-sort
          (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))
          (function
            (lambda (a b)
              (> (caddr (assoc 10 (entget a))) (caddr (assoc 10 (entget b))))
            ) ;_  lambda
          ) ;_  function
        ) ;_  vl-sort
      ) ;_  mapcar
    ) ;_  mapcar
  ) ;_  if
) ;_  defun

The magenta text - outcome of operation of the program...
 

[qjchen]

Thank you, Evgeniy.

a beautiful code, let me study hard for it.

[Kerry]

Evgeniy, that code is a thing of beauty !!