提示列表有缺陷 大神给看看

磐舍

;;; ------------------------------------------------------------------------
;;; CAD闭合线段面积测量工具 (v1.2)
;;; ------------------------------------------------------------------------
;;; 作者：CAD技术开发团队
;;; 功能：智能检测闭合多段线并自动标注面积
;;; 版本：1.2.0
;;; 最后更新：2023-10-15
;;; ------------------------------------------------------------------------

;;; 初始化与清理
(defun libmain ()
  (load (strcat (getenv "ACP_LISP_PATH") "\\closed_poly_area.lsp"))
  (princ)
)

(defun libunmain ()
  (unload-plugin)
  (princ)
)

;;; 核心功能模块
(defun c:CLOSED-POLY-AREA ( / ent )
  "主命令：自动检测闭合多段线并标注面积"
  (interactive)
  (setq ent (ssname (car (getssname))))

  (if (null ent)
      (message-box "错误：请先选择闭合多段线！" "输入错误" MB_OK | MB_ICONERROR)
    (progn
      (setq obj (entget ent))
      (cond
        ;; 仅处理多段线类型
        ((member (cdr (assoc "TYPE" obj)) '("POLYLINE" "LWPOLYLINE"))
         (when (and (check-closed-polyline obj)
                (>= (length (entget obj "VERTEX")) 3))
           (progn
             (auto-label-poly-area obj)
             (display-measurement-results obj)
             (princ)
           )
         )

        (t
         (message-box (strcat "不支持类型：$" (cdr (assoc "TYPE" ent)))
                      "类型错误"
                      MB_OK | MB_ICONWARNING)
      )
    )
  )
  (princ)
)

;;; 闭合性验证模块
(defun check-closed-polyline (ent)
  "使用容差法验证多段线闭合性（精度0.001单位）"
  (let ((verts (entget ent "VERTEX"))
        (first-pt (cdr (assoc 10 (nth 1 verts))))
        (last-pt (cdr (assoc 10 (nth (length verts) verts))))
        tolerance 0.001)
    (and
     (>= (length verts) 3)
     (<= (distance first-pt last-pt) tolerance)
     (equal (cdr (assoc "CLOSED" ent)) "1") ; 检查系统闭合属性
     )
  )
)

;;; 智能标注系统
(defun auto-label-poly-area (ent)
  "自动计算并创建面积标注"
  (let ((verts (entget ent "VERTEX"))
        area
        label-pos
        style
        text-height)

    ;; 计算几何属性
    (setq area (calculate-polygonal-area verts))
    (setq centroid (get-polygon-center verts))

    ;; 获取标注样式
    (setq style (getvar "DIMSTYLE"))
    (setq text-height (getvar "DIMTXTEXT"))

    ;; 智能定位标注位置
    (setq dir (cdr (assoc "DIR" ent)))
    (unless dir
      (setq dir (vector-normalize (subtract-point centroid (car verts)))))
    (setq label-pos (offset-point centroid dir (* text-height 1.5)))

qazxswk

AI写的，找AI解决呀。

tigcat

;;; ------------------------------------------------------------------------
;;; CAD闭合线段面积测量工具 (v1.2)
;;; ------------------------------------------------------------------------
;;; 作者：CAD技术开发团队
;;; 功能：智能检测闭合多段线并自动标注面积
;;; 版本：1.2.0
;;; 最后更新：2023-10-15
;;; ------------------------------------------------------------------------

;;; 初始化与清理
(defun libmain ()
  (load (strcat (getenv "ACP_LISP_PATH") "\\closed_poly_area.lsp"))
  (princ)
)

(defun libunmain ()
  (unload-plugin)
  (princ)
)

;;; 主命令函数
(defun c:CLOSED-POLY-AREA (/ ent obj)
  "主命令：自动检测闭合多段线并标注面积"
  (vl-load-com)  ; 加载ActiveX支持
  (setvar "CMDECHO" 0)  ; 关闭命令回显
  
  (setq ent (ssname (ssget ":S" '((0 . "POLYLINE,LWPOLYLINE"))) 0))
  
  (cond
    ((null ent)
     (alert "错误：请先选择闭合多段线！"))
   
    (t
     (setq obj (entget ent))
     (cond
       ((member (cdr (assoc 0 obj)) '("POLYLINE" "LWPOLYLINE"))
        (if (check-closed-polyline obj)
            (progn
              (auto-label-poly-area obj)
              (display-measurement-results obj))
            (alert "错误：所选多段线未闭合！")))
      
       (t
        (alert (strcat "不支持类型：" (cdr (assoc 0 obj))))))))
  
  (setvar "CMDECHO" 1)  ; 恢复命令回显
  (princ)
)

;;; 闭合性验证函数
(defun check-closed-polyline (ent / verts first-pt last-pt tolerance)
  "使用容差法验证多段线闭合性（精度0.001单位）"
  (setq verts (get-vertices ent)
        tolerance 0.001)
  (and (> (length verts) 2)
       (progn
         (setq first-pt (car verts)
               last-pt (last verts))
         (and (<= (distance first-pt last-pt) tolerance)
              (= (logand (cdr (assoc 70 ent)) 1) 1)))))  ; 检查闭合标志

;;; 面积标注函数
(defun auto-label-poly-area (ent / verts area centroid label-pos text-height dir)
  "自动计算并创建面积标注"
  (setq verts (get-vertices ent)
        area (calculate-polygonal-area verts)
        centroid (get-polygon-center verts)
        text-height (getvar "TEXTSIZE"))
  
  ;; 计算标注位置
  (setq dir (or (cdr (assoc "DIR" ent))
                (vector-normalize
                  (subtract-point centroid (car verts)))))
  (setq label-pos (offset-point centroid dir (* text-height 1.5)))
  
  ;; 创建文本标注
  (command "_.TEXT" "_J" "_MC" label-pos text-height 0
           (strcat "面积: " (rtos area 2 2) " sq.units"))
)

;;; 获取顶点列表
(defun get-vertices (ent / verts pt)
  "从多段线提取顶点坐标列表"
  (setq verts '())
  (if (= (cdr (assoc 0 ent)) "LWPOLYLINE")
      (progn
        (foreach item ent
          (if (= (car item) 10)
              (setq verts (append verts (list (cdr item)))))))
      (progn
        (setq ent (entnext ent))
        (while (and ent (/= (cdr (assoc 0 (entget ent))) "SEQEND"))
          (setq pt (cdr (assoc 10 (entget ent))))
          (setq verts (append verts (list pt)))
          (setq ent (entnext ent)))))
  verts)

;;; 计算多边形面积（鞋带公式）
(defun calculate-polygonal-area (verts / sum1 sum2 i n)
  "使用鞋带公式计算多边形面积"
  (setq n (length verts)
        sum1 0.0
        sum2 0.0
        i 0)
  (while (< i (1- n))
    (setq sum1 (+ sum1 (* (car (nth i verts)) (cadr (nth (1+ i) verts))))
          sum2 (+ sum2 (* (cadr (nth i verts)) (car (nth (1+ i) verts))))
          i (1+ i)))
  (setq sum1 (+ sum1 (* (car (last verts)) (cadr (car verts))))
        sum2 (+ sum2 (* (cadr (last verts)) (car (car verts)))))
  (/ (abs (- sum1 sum2)) 2.0))

;;; 计算多边形质心
(defun get-polygon-center (verts / area xsum ysum i n pt)
  "计算多边形质心"
  (setq area (calculate-polygonal-area verts)
        xsum 0.0
        ysum 0.0
        n (length verts)
        i 0)
  (while (< i (1- n))
    (setq pt (* (+ (car (nth i verts)) (car (nth (1+ i) verts)))
                (- (* (car (nth i verts)) (cadr (nth (1+ i) verts)))
                   (* (cadr (nth i verts)) (car (nth (1+ i) verts)))))
          xsum (+ xsum pt)
          ysum (+ ysum pt)
          i (1+ i)))
  (setq pt (* (+ (car (last verts)) (car (car verts)))
              (- (* (car (last verts)) (cadr (car verts)))
                 (* (cadr (last verts)) (car (car verts)))))
        xsum (+ xsum pt)
        ysum (+ ysum pt))
  (list (/ xsum (* 6.0 area)) (/ ysum (* 6.0 area))))

;;; 向量标准化
(defun vector-normalize (vec / mag)
  "将向量标准化为单位向量"
  (setq mag (sqrt (apply '+ (mapcar '* vec vec))))
  (if (> mag 0)
      (mapcar '(lambda (x) (/ x mag)) vec)
      vec))

;;; 点坐标相减
(defun subtract-point (p1 p2)
  "计算两点之间的向量"
  (mapcar '- p1 p2))

;;; 点沿方向偏移
(defun offset-point (pt dir dist)
  "沿指定方向偏移点"
  (mapcar '+ pt (mapcar '(lambda (x) (* x dist)) dir)))

;;; 显示测量结果
(defun display-measurement-results (obj / area)
  "在命令行显示测量结果"
  (setq area (calculate-polygonal-area (get-vertices obj)))
  (princ (strcat "\n测量结果 - 面积: " (rtos area 2 2) " 平方单位"))
  (princ))

;;; 程序加载提示
(princ "\nCLOSED-POLY-AREA 加载完成。输入 CLOSED-POLY-AREA 开始使用。")
(princ)

kozmosovia

biya 发表于 2025-3-15 06:45
你怎么一眼看出来的是AI?引号全是3对？

你觉得中国写代码的。有人会这样命名函数的？
(progn
             (auto-label-poly-area obj)
             (display-measurement-results obj)
             (princ)
           )

  (setq dir (vector-normalize (subtract-point centroid (car verts)))))

tryhi

你数一下有多少左括号（帮你数了94个），再数一下有多少个右括号（又帮你数了90个），不就知道问题在哪了吗？

kozmosovia

让AI写代码，然后写出来的自己都懒得花时间研究，这哪还有一点编程学习的样子。

xyp1964

message-box when let都是啥玩意？

kozmosovia

xyp1964 发表于 2025-3-13 17:10
message-box when let都是啥玩意？

一眼早年间AI的作品。

Dea25

xyp1964 发表于 2025-3-13 17:10
message-box when let都是啥玩意？

我还以为只有我不认识这些函数o-o-o-

czb203

神奇的代码

liuhe

xyp1964 发表于 2025-3-13 17:10
message-box when let都是啥玩意？

Common Lisp函数