📄 线性方程组.lsp
字号:
;;求线性方程组的解
(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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -