cad表达式数学计算插件，在论坛已经有的程序程序上如何增加函数

664571221

有时候cad中有一些要计算结果的计算式，比如：2+6-2^2*56   等，找了几个插件，还只有源泉建筑插件能够计算数学表达式，并且很方便，可如果光为这功能安装一个很多功能的源泉实在有些不划算。

论坛已经有的代码  可能是高飞鸟的

;;;=============================================================
;;; 函数目的: 字符表达式转为函数，主要用于多次调用时提升速度   
;;; 输入: expr--字符表达式,sFunc--函数名,sArg--参数符号列表     
;;; 输出: 定义函数，并返回其名                                 
;;; 例子: (CAL:Expr2Func "sin(x)+20*y" 'test '(x y))            
;;; 结果: 定义了一个名为test的函数，参数符号为x y               
;;; 注意: 除法区分整数和浮点数，譬如"2/3"和"2/3.0"结果不同；   
;;;       可用自定义函数，前提是首先要加载；                    
;;;       可用科学计算法，但应满足LISP中的语法。建议用括号；   
;;;       表达式应满足语法要求，小数和乘号不能按省略写法。      
;;;=============================================================
(defun CAL:Expr2Func (expr sFunc sArgs / lst)        
  (setq lst (CAL:Separate expr))                                ;先按照括号空格和运算符分离字符
  (setq lst (CAL:Operators lst '((^ . expt)) ()))                ;乘方（幂）最优先
  (setq lst (CAL:Operators lst '((* . *) (/ . /) (% . rem)) ()));其次乘除和求模运算
  (setq lst (CAL:Operators lst '((+ . +) (- . -)) ()))                ;最后处理加减法运算
  (eval (cons 'defun (cons sFunc (cons sArgs lst))))            ;表达成函数
)

;;;=============================================================
;;; 函数目的: 字符表达式求值                                    
;;; 输入: expr--字符表达式                                      
;;; 输出: 计算表达式的结果                                      
;;; 例子: (CAL:Expr2Value "sin(1)+20*2")                        
;;; 结果: 40.8415                                               
;;;=============================================================
(defun CAL:Expr2Value (expr / lst)
  (setq lst (CAL:Separate expr))                                ;先按照括号空格和运算符分离字符
  (setq lst (CAL:Operators lst '((^ . expt)) ()))                ;乘方（幂）最优先
  (setq lst (CAL:Operators lst '((* . *) (/ . /) (% . rem)) ()));其次乘除和求模运算
  (setq lst (CAL:Operators lst '((+ . +) (- . -)) ()))                ;最后处理加减法运算
  (eval (car lst))                                                ;求值
)

;;;=============================================================
;;; 函数目的: 先分离出函数和+-*/%^运算符，其余均视作变量或数值，
;;; 并简单检查括号匹配。                                       
;;; 输入: expr--字符表达式                                      
;;; 输出: 函数（包括运算符）和变量及数值的列表                  
;;;=============================================================
(defun CAL:Separate (expr / CHAR FUNS LASTCHAR LST Temp LBRACKET RBRACKET next)
  (setq expr (vl-string-translate "{[]}\t\n," "(())   " expr))  ;替换{[]}\t\n,字符
  (setq expr (strcase expr t))                                        ;全部转为小写
  (setq funs '("+" "-" "*" "/" "^" "%" ))                        ;按照基本运算符分割字符
  (setq Temp "")
  (setq lst "(")
  (setq Lbracket 0)                                                ;左括号计数器
  (setq Rbracket 0)                                                ;右括号计数器
  (while (/= expr "")
    (setq char (substr expr 1 1))                               ;字符串的第一个字符
    (setq next (substr expr 2 1))                                ;字符串的第二个字符
    (if        (or (= char "(")
            (= char ")")                                        ;括号一定是分隔符
            (and (= char " ") (/= next "(") (/= next " "))      ;如果不是连续的空格符
            (and (member char funs)                                ;根据运算符进行分割
                 (not (CAL:isScientific temp lastchar char))    ;忽略科学计数法
            )                                                                                 
        )
      (progn
        (if (CAL:IsFunction (Read temp))                        ;如果为普通函数
          (setq        lst         (strcat lst "(" Temp " " )                ;则把括号移至函数符号前
                Lbracket (1+ Lbracket)                                ;左括号计数器加1
          )
          (progn
            (and (= char "(") (setq Lbracket (1+ Lbracket)))    ;左括号计数器加1
            (and (= char ")") (setq Rbracket (1+ Rbracket)))        ;右括号计数器加1
            (setq lst (strcat lst Temp " " char " "))
          )
        )
        (setq Temp "")                                          ;如果是函数或者括号空格之类，则在此处重新开始  
      )
      (setq Temp (strcat Temp char))                            ;否则连取这个字符
    )
    (setq expr (substr expr 2))                                        ;字符串剩下的字符
    (setq lastchar char)
  )
  (if (/= Lbracket Rbracket)                                        ;如果括号不平衡
    (alert "括号不匹配(Mismatched Brackets)!")                        ;警告信息
    (read (strcat lst Temp ")"))                                ;否则转为表
  )
)

;;;=============================================================
;;; 函数目的: 分析+-*/%^运算符，并组合到表中                    
;;; 输入: lst-已分割的表,funs-待分析的运算符,Recursive-是否递归
;;; 输出: 函数（包括运算符）和变量及数值的列表                  
;;;=============================================================
(defun CAL:Operators (lst funs Recursive / fun L n)
  (foreach a lst
    (if        (listp a)
      (setq a (CAL:Operators a funs T))                                ;如果元素为表，则递归进去
    )
    (if        (setq fun (cdr (assoc (car L) funs)))                   ;前一个符号为+-*/%^运算符
      (if (or (null (setq n (cadr L)))                          ;前前一个符号为空
              (and (VL-SYMBOLP n) (CAL:IsFunction n))           ;或者是函数符号
          )
        (setq L (cons (list fun a) (cdr L)))                    ;无须交换位置
        (setq L (cons (list fun n a) (cddr L)))                        ;交换运算符和操作数位置
      )
      (setq L (cons a L))                                       ;其他的不做改变
    )                                            
  )
  (setq n (car L))
  (if (and Recursive (not (cadr L)) (or (listp n) (numberp n))) ;如果是递归的,而且只有一个元素，且这个元素为表或者数字
    n                                                                ;那么就只取这个元素，以防止多余括号出现
    (reverse L)                                                        ;cons运算后的反转表列
  )
)

;;;=============================================================
;;; 函数目的: 判断一个符号是不是普通函数（内部函数或自定义函数）
;;;=============================================================
(defun CAL:IsFunction (n)
  (setq n (type (eval n)))
  (or (= n 'SUBR) (= n 'USUBR))
)

;;;=============================================================
;;; 函数目的: 检测一个字符串是否是科学计数法(是否有更好方法?)   
;;;=============================================================
(defun CAL:isScientific (temp lastchar char)
  (and (= lastchar "e") (numberp (read (strcat temp char "0"))))
)


;|
;;; 例子:
;;; (CAL:Separate "(sin(-x)-cos(-x+(1+8*(2/7))+2^4-5))*0.5-0.5e-20+20*cos(x)+20")
;;; 结果: ((SIN - X) - (COS - X + (1 + 8 * (2 / 7)) + 2 ^ 4 - 5))
;;; (CAL:Expr2Func "(sin(+x)-cos(-x+(1+8*(2/7))+(2^4)-5))*0.5-0.5e-20+20*cos(x)+20" 'test '(x))
;;; 结果: 定义了一个名为test的函数，参数符号为x
;;; (CAL:Expr2Value "(sin(+0.5)-cos(-pi+(1+8*(2/7))+(2^4)-5))*0.5-0.5e-20+20*cos(pi/2)+20")
;;; 结果: 20.6616
;;; 以下是关于这个程序的其他方法：
;;; 方法一:用cal函数计算
;;; 如cal "1+4+5*2+(5+5)/2+((6+6)/2+(5+5)/2)")
;;; 优点：CAD内置函数。
;;; 缺点：这个函数要求先要加载cal函数.并且三角函数会自动把变量或者数值理解为角度。
;;; 方法二:wcs脚本语言法,无痕提出的一种方法
;;; (setq wcs (vla-GetInterfaceObject (vlax-get-acad-object) "ScriptControl"))
;;; (vlax-put-property wcs "language" "vbs")
;;; (vla-eval wcs "1+4+5*2+(5+5)/2+((6+6)/2+(5+5)/2)")  ;返回 ->31.0
;;; 优点：能按照vb的语法直接计算。
;;; 缺点：难以定义表达式为函数，不能利用自定义函数，在64位CAD上此法行不通，因为不能创建脚本对象。
;;; 下面例子为在CAD中绘制函数图像
(defun c:test1()
  (setq expr (getstring "\n请输入表达式:"))
  (initget 1)
  (setq a (getreal "\n上届:"))
  (initget 1)
  (setq b (getreal "\n下届:"))
  (if (CAL:EXPR2FUNC  expr 'test '(x))
    (progn
      (setq d (/ (- b a) 1000.0))
      (setq x a)
      (setq pts nil)
      (repeat 1000
        (setq x (+ x d))
        (setq y (test x))
        (setq pts (cons (list x y 0) pts))
      )
      (setq pts (reverse pts))
      (setq e (Entmake (list '(0 . "OLYLINE") '(70 . 8))))
      (foreach p pts
        (entmake (list '(0 . "VERTEX") '(70 . 32) (cons 10 p)))
      )
      (entmake '((0 . "SEQEND")))
      (entlast)
    )
  )
)
;;; 在CAD中绘制参数曲线
;;; x=a*(2*cos(t)-cos(2*t))
;;; y=a*(2*sin(t)-sin(2*t))
(defun c:test2 ()
  (setq expr1 "3*(2*cos(k)-cos(2*k))")
  (setq expr2 "3*(2*sin(k)-sin(2*k))")
  (setq a 0)
  (setq b (+ pi pi))
  (CAL:EXPR2FUNC expr1 'fx '(k))
  (CAL:EXPR2FUNC expr2 'fy '(k))
  (setq d (/ (- b a) 360))
  (setq k a)
  (setq pts nil)
  (repeat 360
    (setq k (+ k d))
    (setq x (fx k))
    (setq y (fy k))
    (setq pts (cons (list x y 0) pts))
  )
  (setq pts (reverse pts))
  (setq e (Entmake (list '(0 . "OLYLINE") '(70 . 9))))
  (foreach p pts
    (entmake (list '(0 . "VERTEX") '(70 . 32) (cons 10 p)))
  )
  (entmake '((0 . "SEQEND")))
  (entlast)
)
;;; 定义为函数后，明显速度快多了
(defun c:test3()
  (setq str1 "(sin(+x)-cos(-x+(1+8*(2/7.0))+(2^4)-5))*0.5-0.5e-20+20*cos(x)+20")
  (setq str2 "(sin(r2d(x))-cos(r2d(-x+(1+8*(2/7.0))+(2^4)-5)))*0.5-0.5e-20+20*cos(r2d(x))+20")
  (CAL:Expr2Func str1 'f1 '(x))
  (setq x 12)
  (uti:bench 1000
    (list
      (cons 'f1 '(12))
      (cons 'CAL:Expr2Value (list str1))
      (cons 'cal (list str2))
    )
  )
)

;;|;