curve:optimize-lwpl

说明：优化多段线顶点。当连续多点共线或共圆时，减少顶点。优化顺时针的多段线有问题待修复。优化会丢失宽度信息！！

用法：

 (curve:optimize-lwpl ent)

参数：1 ent : 单个图元;

返回值：优化后的新图元

示例：

(defun curve:optimize-lwpl (ent / segs res n1 n2 n3 fuzz)
  "优化多段线顶点。当连续多点共线或共圆时，减少顶点。优化顺时针的多段线有问题待修复。优化会丢失宽度信息！！"
  "优化后的新图元"
  (if (numberp tmp-fuzz)
    (setq fuzz tmp-fuzz)
    (setq fuzz 1.0e-08))
  (setq segs (mapcar (quote (lambda (x y)
          (cons x y)))
      (curve:pline-3dpoints ent)
      (curve:pline-convexity ent)))
  (setq n1 (car segs))
  (setq res (cons n1 nil))
  (setq segs (cdr segs))
  (setq n2 (car segs))
  (setq res (cons n2 res))
  (setq segs (cdr segs))
  (while (setq n3 (car segs))
    (cond ((and (= 0 (cdr n1))
          (= 0 (cdr n2))
          (equal (angle (car n1)
              (car n2))
            (angle (car n2)
              (car n3))
            fuzz)
          (setq res (cons n3 (cdr res)))))
      ((and (/= 0 (cdr n1))
          (/= 0 (cdr n2))
          (equal 0 (distance (curve:bulge2o (car n1)
                (car n2)
                (cdr n1))
              (curve:bulge2o (car n2)
                (car n3)
                (cdr n2)))
            fuzz))
        (setq res (cons (cons (car n1)
              (curve:o2bulge (car n1)
                (car n3)
                (curve:bulge2o (car n1)
                  (car n2)
                  (cdr n1))))
            (cddr res)))
        (setq res (cons n3 res)))
      (t (setq res (cons n3 res))))
    (setq n1 (cadr res))
    (setq n2 (car res))
    (setq segs (cdr segs)))
  (if (= 1 (entity:getdxf ent 70))
    (progn (setq n3 (last res))
      (cond ((and (= 0 (cdr n1))
            (= 0 (cdr n2))
            (equal (angle (car n1)
                (car n2))
              (angle (car n2)
                (car n3))
              fuzz)
            (setq res (cdr res))))
        ((and (/= 0 (cdr n1))
            (/= 0 (cdr n2))
            (equal 0 (distance (curve:bulge2o (car n1)
                  (car n2)
                  (cdr n1))
                (curve:bulge2o (car n2)
                  (car n3)
                  (cdr n2)))
              fuzz))
          (setq res (cons (cons (car n1)
                (curve:o2bulge (car n1)
                  (car n3)
                  (curve:bulge2o (car n1)
                    (car n2)
                    (cdr n1))))
              (cddr res)))))
      (setq n1 (car res))
      (setq n2 (last res))
      (setq n3 (cadr (reverse res)))
      (cond ((and (= 0 (cdr n1))
            (= 0 (cdr n2))
            (equal (angle (car n1)
                (car n2))
              (angle (car n2)
                (car n3))
              fuzz)
            (setq res (reverse (cdr (reverse res))))))
        ((and (/= 0 (cdr n1))
            (/= 0 (cdr n2))
            (equal 0 (distance (curve:bulge2o (car n1)
                  (car n2)
                  (cdr n1))
                (curve:bulge2o (car n2)
                  (car n3)
                  (cdr n2)))
              fuzz))
          (setq res (cons (cons (car n1)
                (curve:o2bulge (car n1)
                  (car n3)
                  (curve:bulge2o (car n1)
                    (car n2)
                    (cdr n1))))
              (cddr res)))))))
  (setq res (reverse res))
  (entity:make-lwpline-bold (mapcar (quote car)
      res)
    (mapcar (quote cdr)
      res)
    0 (entity:getdxf ent 70)
    0))

@lisp 函数库

介绍

调用函数

安装教程

快速上手：

curve:optimize-lwpl

上传记录