TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: qjchen on November 11, 2006, 07:15:14 AM
-
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 :)
;;; ===================================================;
;;; 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)
-
That's cool stuff Chen! Thanks for sharing. :-)
-
Great work!! I can't wait to dig into it deeper. Thanks for this and all your great posts..
-
Now that's sweet, Thanks.
-
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~~~
-
(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...
:-)
-
Thank you, Evgeniy.
a beautiful code, let me study hard for it.:)
-
Evgeniy, that code is a thing of beauty !!