数字按规律求和

革天明

在8楼的基础上增加，核心功能是byghbcx编写的，借鉴了很多高人的代码，在此谢过！
下载附件，数字按规律求和-电力.LSP，在CAD界面中输入AP，找到这个文件，点击加载按钮，
加载完毕后，输入test1，回车后选择图中文字，回车确认后要求指定一点，程序会在此点处生成A、B、C的值
;;;(setq lst '(5 6 7 7.5 8.5 9.3 8.2 6.7 4.5 3.3))
;;;(byghbcx-test lst)
(defun byghbcx-test (lst / n lst1 m s sa sb sc)
   (defun lst_sort (lst fun)                ;表从小到大排序
     (mapcar 'cdr
            (vl-sort (mapcar '(lambda (x) (cons 1 x)) lst) fun)
     )
   )
   (setq n (length lst))
   (cond        ((= (rem n 3) 0))
        ((= (rem n 3) 1) (setq lst (cons 0 (cons 0 lst))))
        ((= (rem n 3) 2) (setq lst (cons 0 lst)))
   )
   (setq        lst1 (lst_sort lst '(lambda (e1 e2) (> (cdr e1) (cdr e2))))
        m    (length lst1)
   )
   (setq s (list (cons 1 0) (cons 2 0) (cons 3 0)))
   (repeat (/ m 3)
     (setq SA   (car lst1)
          SB   (cadr lst1)
          SC   (caddr lst1)
          lst1 (cdddr lst1)
     )
     (setq s (vl-sort s '(lambda (e1 e2) (< (cdr e1) (cdr e2)))))
     (setq
       s        (mapcar        '(lambda (x y) (setq y (cons (car y) (+ x (cdr y)))))
                (list sa sb sc)
                s
        )
     )
   )
   (setq s (vl-sort s '(lambda (e1 e2) (< (car e1) (car e2)))))
   (setq pt (getpoint "\n请选择基准点:"))
   ;;(princ (strcat "\nA=" (rtos (cdar s))))
   (entmake (list '(0 . "TEXT")
                 (cons 1 (strcat "\nA=" (rtos (cdar s))))
                 (cons 10 pt)
                 (cons 40 5)
           )
   )
   ;;(princ (strcat "\nB=" (rtos (cdadr s))))
   (entmake (list '(0 . "TEXT")
                 (cons 1 (strcat "\nB=" (rtos (cdadr s))))
                 (cons 10 (polar pt (* pi 1.5) 8))
                 (cons 40 5)
           )
   )
   ;;(princ (strcat "\nC=" (rtos (cdar (cddr s)))))
   (entmake
     (list '(0 . "TEXT")
          (cons 1 (strcat "\nC=" (rtos (cdar (cddr s)))))
          (cons 10 (polar pt (* pi 1.5) 16))
          (cons 40 5)
     )
   )
)
(defun c:test1 ()
   ;;================================================================================================
   (defun mtext2text (MTextString / regex s)
     (setq regex (vlax-create-object "Vbscript.RegExp"))
                                        ;引用正则表达式控件
     (vlax-put-property regex "IgnoreCase" 0) ;不忽略大小写
     (vlax-put-property regex "Global" 1) ;匹配方式，全文字匹配
     (setq s MTextString)
                                        ;替换\\字符
     (vlax-put-property regex "Pattern" "\\\\\\\\")
     (setq s (vlax-invoke-method regex "Replace" s (chr 1)))
                                        ;替换\{字符
     (vlax-put-property regex "Pattern" "\\\\{")
     (setq s (vlax-invoke-method regex "Replace" s (chr 2)))
                                        ;替换\}字符
     (vlax-put-property regex "Pattern" "\\\\}")
     (setq s (vlax-invoke-method regex "Replace" s (chr 3)))
                                        ;删除段落缩进格式
     (vlax-put-property regex "Pattern" "\\\\pi(.[^;]*);")
     (setq s (vlax-invoke-method regex "Replace" s ""))
                                        ;删除制表符格式
     (vlax-put-property regex "Pattern" "\\\\pt(.[^;]*);")
     (setq s (vlax-invoke-method regex "Replace" s ""))
                                        ;删除堆迭格式
     (vlax-put-property
       regex
       "Pattern"
       "\\\\S(.[^;]*)(\\^|#|\\\\)(.[^;]*);"
     )
     (setq s (vlax-invoke-method regex "Replace" s ""))
                                        ;删除字体、颜色、字高、字距、倾斜、字宽、对齐格式
     (vlax-put-property
       regex
       "Pattern"
       "(\\\\F|\\\\f|\\\\C|\\\\H|\\\\\T|\\\\Q|\\\\W|\\\\A)(.[^;]*);"
     )
     (setq s (vlax-invoke-method regex "Replace" s ""))
                                        ;删除下划线、删除线格式
     (vlax-put-property
       regex
       "Pattern"
       "(\\\\L|\\\\O|\\\\l|\\\\o)"
     )
     (setq s (vlax-invoke-method regex "Replace" s ""))
                                        ;删除不间断空格格式
     (vlax-put-property regex "Pattern" "\\\\~")
     (setq s (vlax-invoke-method regex "Replace" s ""))
                                        ;删除换行符格式
     (vlax-put-property regex "Pattern" "\\\\P")
     (setq s (vlax-invoke-method regex "Replace" s ""))
                                        ;删除换行符格式(针对Shift+Enter格式)
     (vlax-put-property regex "Pattern" "\n")
     (setq s (vlax-invoke-method regex "Replace" s ""))
                                        ;删除{}
     (vlax-put-property regex "Pattern" "({|})")
     (setq s (vlax-invoke-method regex "Replace" s ""))

                                        ;替换回\\,\{,\}字符
     (vlax-put-property regex "Pattern" "\\x01")
     (setq s (vlax-invoke-method regex "Replace" s "\\"))
     (vlax-put-property regex "Pattern" "\\x02")
     (setq s (vlax-invoke-method regex "Replace" s "{"))
     (vlax-put-property regex "Pattern" "\\x03")
     (setq s (vlax-invoke-method regex "Replace" s "}"))

     (vlax-release-object regex)
     s
   )
;;;----通用函数-----
   ;;carrot1983  http://bbs.mjtd.com/forum.php?mod=viewthread&tid=64502
   ;;选择集->图元名表
   (defun ss->elst (ss / elst)
     (setq i 0)
     (repeat (sslength ss)
       (setq elst (cons (ssname ss i) elst)
            i         (1+ i)
       )
     )
     (reverse elst)
   )
   (setq ss (ss->elst (ssget '((0 . "text,mtext")))))
   (setq        numlist
         (mapcar '(lambda (x)
                    (atof (vl-string-left-trim
                            " "
                            (vl-string-right-trim
                              " "
                              (mtext2text (cdr (assoc 1 (entget x))))
                            )
                          )
                    )
                  )
                 ss
         )
   )
   (byghbcx-test numlist)
)

byghbcx

zhengchuan 发表于 2012-9-22 00:54
byghbcx 兄，已加载您这个程序
命令: (setq lst '(5  6  7  7.5  8.5  9.3  8.2  6.7  4.5  3.3))
(5 6 ...

这个版块可能讨论的大多是VLISP编程技术与方法，如果没什么基础的话在交流上会存在一定的问题，如果是讨要程序的话，可以把测试图，编程要求发上来会有热心人帮忙的。20楼的程序可能会符合你的要求。

zhengchuan

革天明 发表于 2012-9-22 08:34
在8楼的基础上增加，核心功能是byghbcx编写的，借鉴了很多高人的代码，在此谢过！
下载附件，数字按规律求 ...

革兄，非常感谢。实现了一个功能。其实我最想的是将数字转成ABC。不知能否实现

革天明

zhengchuan 发表于 2012-9-22 15:04
革兄，非常感谢。实现了一个功能。其实我最想的是将数字转成ABC。不知能否实现

图太小，看不清，传DWG，里面字体设成宋体吧，你的字体我打开乱码

zhengchuan

革天明 发表于 2012-9-22 15:23
图太小，看不清，传DWG，里面字体设成宋体吧，你的字体我打开乱码

好的。

xyp1964

函数 NumPlus
(NumPlus '(5 6 7 7.5 8.5 9.3 8.2 6.7 4.5 3.3))→(23.8 21.5 20.7)

xyp1964

xyp1964

zml84

描述了大半天，我才明白。 一大堆数据，分装三个容器，要求每个容器数据和，相差最小。
貌似还有更优解。

1. ;;=================================================
   
2. 相位 = A   sum = 21.00   成员 = (9.3 6.7 5)
   
3. 相位 = B   sum = 23.80   成员 = (7.5 7 6 3.3)
   
4. 相位 = C   sum = 21.20   成员 = (8.5 8.2 4.5)
   
5. ;;=================================================

;;================================================= <br /> 相位 = A   sum = 21.00   成员 = (9.3 6.7 5) <br /> 相位 = B   sum = 23.80   成员 = (7.5 7 6 3.3) <br /> 相位 = C   sum = 21.20   成员 = (8.5 8.2 4.5) <br /> ;;=================================================

zhengchuan

xyp1964 发表于 2012-9-23 09:45

院长，您这个实现要装您那个工具箱吗？如果不装，可实现吗？