solve6.lsp

autolisp编写的解决一元线性方程的程序

;;;主程序
(prompt "请输入solve命令!")
(defun C:solve (/ f x1 x2 n id err result str1 str2 str3 str4 str5)
  (setq id (load_dialog "solve1.dcl"))
  (if (new_dialog "dcl_solve" id)
    (progn
      (action_tile "p1" "(setq f $value)")  ;从对话框中得到表达式
      (action_tile "p2" "(setq x1 $value)") ;从对话框中得到下届
      (action_tile "p3" "(setq x2 $value)") ;从对话框中得到上届
      (action_tile "p4" "(setq n $value)")  ;从对话框中得到精度
      (action_tile "help" "(choose 1)")     ;帮助
      (start_dialog)
      (unload_dialog id)
      (if (and x1 x2 n f)
	(progn
	  (setq x1 (atof x1) x2 (atof x2) n (abs (atoi n)) n (if (> n 20) 20 n))
	  (setq err (vl-catch-all-apply 'zbrent (list f x1 x2 n)))
	  (if (vl-catch-all-error-p err)
	    (alert (strcat "方程无解或者" (vl-catch-all-error-message err)))
	    (progn
	      (setq str1 (car result)
		    str2 "\n下面是求解验证结果:"
		    str3 (cadr result)
		    str4 (caddr result)
		    str5 (strcat str1 str2 "\nf(" str3 ")=" str4)
	      )
	      (alert str5)
	      (princ str5)
	    )
	  ) 
	)
      )
    )
  )
  (princ) 
)
;;;*********************************************
;;;用Van Wijingaarden-Dekker-Brent方法求解的函数
;;;*********************************************
(defun zbrent (f x1 x2 n / a b c d e fa fb fc EPS ITMAX i xm test
		           tol tol1 min1 min2 p q r s fra_x int_x)
  (setq tol (expt 0.1 n));容差
  (setq ITMAX 10000)     ;最大迭代次数
  (setq EPS 1e-16)       ;计算机有效精度
  (if (> x1 x2)          ;如果下届大于上届
    (setq a x2 b x1 c x1);则交换上下界
    (setq a x1 b x2 c x2)
  )
  (setq fa (func a))
  (setq fb (func b)) 
  (if (or (and (> fa 0) (> fb 0)) (and (< fa 0) (< fb 0)));上下界函数值同号
    (princ "\nRoot must be bracketed in zbrent!")
  )
  (setq fc fb)
  (setq i 1)
  (while (<= i ITMAX)
    (if (or (and (> fb 0) (> fc 0))
	    (and (< fb 0) (< fc 0)))
      (setq c a fc fa d (- b a) e d);对a,b,c更名并调整解区间d
    )
    (if (< (abs fc) (abs fb))
      (setq a b b c c a fa fb fb fc fc fa)                     
    )
    (setq tol1 (+ (* 2.0 EPS (abs b)) (* 0.5 tol)));收敛性检查
    (setq xm (* 0.5 (- c b)))
    (if (or (<= (abs xm) tol1) (equal fb 0 1e-16));跳出循环
      (setq i ITMAX)
      (progn
        (if (and (>= (abs e) tol1)
	         (> (abs fa) (abs fb)))
          (progn
	    (setq s (/ fb fa));将进行第二次反插
	    (if (equal a c 1e-16)
	      (setq p (* 2.0 xm s)
		    q (- 1.0 s)
	      )
	      (setq q (/ fa fc)
		    r (/ fb fc)
		    p (* s (- (* 2.0 xm q (- q r)) (* (- b a) (1- r))))
		    q (* (1- q) (1- r) (1- s))
	      )
	    )
	    (if (> p 0) (setq q (- q)));检查是否在解区间内
	    (setq p (abs p))
	    (setq min1 (- (* 3.0 xm q) (abs (* tol1 q))))
	    (setq min2 (abs (* e q)))
	    (if (< (* 2.0 p) (if (< min1 min2) min1 min2))
	      (setq e d d (/ p q));可以进行内插
	      (setq d xm e d);不能进行内插，改用二分法
	    )
          )
          (setq d xm e d);届下降速度太慢，改用二分法
        )
        (setq a b);将最新估值赋给a
        (setq fa fb)
        (if (> (abs d) tol1);计算新的实验解
          (setq b (+ b d))
          (setq b (+ b (if (>= xm 0)(abs tol1) (- (abs tol1)))))
        )
        (setq fb (func b))
      )
    )
    (setq i (1+ i))
  )
  (setq test (func b))
  (setq fra_x (rtos (- (abs b) (fix (abs b))) 2 n))
  (setq fra_x (vl-string-left-trim "0" fra_x))
  (setq int_x (itoa (fix b)))
  (if (equal test 0 1) 
    (setq result (strcat "\n方程" f "=0" "的解为:" int_x fra_x)
	  result (list result (strcat int_x fra_x) (rtos test 1 n))
    )
    (setq result (strcat "\n方程" f "=0" "在此区间无解")
	  result (list result (strcat int_x fra_x) (rtos test 1 n))
    )
  )
)
;;;帮助说明函数
(defun choose (n)
  (if (= n 1)
    (alert "方程式只接受x(小写)为变量,不规范很可能出错!
           \n无须写等式,例如求解x^2-2=0写作x^2-2.
           \n程序采用brent方法求解,不保证每个方程都有效!
	   \n有什么问题email: [e-mail]"
    )
    ;;(set_tile "error" "方程式只接受x(小写)为变量,无须写等式,例如求解x^2-2=0写作x^2-2.")
  )
)
;;;用方式1定义表达式求值函数
(defun func1 (x)
  (arxload "geomcal.arx")
  (cal f)
)
;;;用方式2定义表达式求值函数
(defun func (x / fun vbeval)
  (setq fun f)
  (while (Wcmatch fun "*x*")
    (setq fun (vl-string-subst (rtos x 2 20) "x" fun))
  )
  (vla-eval
    (vlax-get-acad-object)
    (strcat "ThisDrawing.SetVariable \"users1\",Cstr(" fun ")")
  )
  (atof (getvar "users1"))
)
(defun sign (x y)
  (if (>= y 0)
    (abs x)
    (- (abs x))
  )
)