社区 › AutoLISP/Visual LISP 编程技术 › 我经常要做这样的事

357785513 发表于 2015-10-27 20:46:58

我经常要做这样的事

各位高手,我经常要做这样的事,就是把四根线用一根多段线
连起来有没有什么办法框选四根线就，一根多段线把他们连起来了

357785513 发表于 2015-10-28 22:04:38

这是画找坡线，经常要画这些东东

xyp1964 发表于 2015-10-28 23:03:03

357785513 发表于 2015-10-28 23:10:07

院长可以呀，对了24942984我怎么加不进去呀，

357785513 发表于 2015-10-28 23:13:20

无院院长核心代码

aihuyujian 发表于 2015-10-29 10:21:49

框选四条直线 并获取框选时的角点左边 然后获取直线顶点坐标 筛选在框选范围内的顶点坐标 用这些顶点坐标生成pl线感觉就是这样

424069638 发表于 2016-1-11 17:55:48

支持一下，，，，，，

香田里浪人 发表于 2016-1-15 08:48:50

本帖最后由 香田里浪人 于 2016-1-15 08:51 编辑

可以根据下面程序请楼主再修改一下
;;;------------------------TSP------------------------------------------------------------;;;
;;;---------------------------------------------------------------------------------------;;;
(defun c:ylx (/ foo f2 ptl lst l n i d0 l0 l1 d1)
(defun foo (l / D D0 D1)
    (setq l0 (mapcar (function list) (cons (last l) l) l)) ;_setq
;_defun
    (setq d0 (get-closedpolygon-length l))
    (while
      (> d0
         (progn
         (foreach a l0
             (setq d (get-closedpolygon-length l))
             (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
             (setq l1 (f1 (car a) l1))
             (setq l1 (f1 (cadr a) l1))
             (if (> d
                  (setq d1 (get-closedpolygon-length l1))
               )
               (setq d d1
                     l l1
               ) ;_setq
             ) ;_if
             (setq l1 (vl-remove (car a) (vl-remove (cadr a) l)))
             (setq l1 (f1 (cadr a) l1))
             (setq l1 (f1 (car a) l1))
             (if (> d
                  (setq d1 (get-closedpolygon-length l1))
               )
               (setq d d1
                     l l1
               )
             )
         )
         d
         ) ;_progn
      ) ;_<
       (setq d0 d)
    ) ;_while   
    (setq d (get-closedpolygon-length l))   
    l
)
(defun f1 (a l)
    (ins-lst a (get-closest-i l a) l)
)
(defun f2 (lst)
    (mapcar (function (lambda (p0 p p1 / a)
                        (setq a (- (angle p p0) (angle p p1)))
                        (if (< a (- pi))
                        (abs (+ a pi pi))
                        (if (> a pi)
                            (abs (- a pi pi))
                            (abs a)
                        )
                        )
                      )
            )
            (cons (last lst) lst)
            lst
            (reverse (cons (car lst) (reverse (cdr lst))))
    )
)
(setq      ptl (my-getpt)
      ptl (mapcar (function (lambda (p) (list (car p) (cadr p)))) ptl)
)
(setq t1 (getvar "MilliSecs"))
(setq lst (Graham-scan ptl))
(foreach a lst
    (setq ptl (vl-remove a ptl))
)
(while (and (> (length ptl) 2) (setq l (Graham-scan ptl)))
    (foreach p l
      (setq ptl (vl-remove p ptl))
      (setq n (get-minadddist-i lst p))
      (setq lst (ins-lst p n lst))
    )
)
(if ptl
    (foreach p ptl
      (setq n (get-minadddist-i lst p))
      (setq lst (ins-lst p n lst))
    )
)
(setq lst (foo lst))
(setq l (f2 lst))
(setq      i0
      l0 lst
      n(length lst)
      d0 (get-closedpolygon-length lst)
)
(foreach a l
    (if      (and (< a _pi3) (= (setq p (nth i lst)) (nth i l0)))
      (progn
      (if (= i 0)
          (setq p0 (last lst))
          (setq p0 (nth (1- i) lst))
      )
      (if (= i (1- n))
          (setq p1 (car lst))
          (setq p1 (nth (1+ i) lst))
      )
      (setq m      (list (list p0 p1 p)
                      (list p1 p p0)
                      (list p1 p0 p)
                      (list p p0 p1)
                      (list p p1 p0)
                )
      )
      (setq l1
               (car (vl-sort (mapcar (function (lambda (x)
                                                 (ch-para-lst x i lst)
                                             )
                                     )
                                     m
                           )
                           (function (lambda (e1 e2)
                                       (< (get-closedpolygon-length e1)
                                          (get-closedpolygon-length e2)
                                       )
                                       )
                           )
                  )
               )
      )
      (setq d1 (get-closedpolygon-length l1))
      (if (< d1 d0)
          (setq      d0d1
                lst l1
          )
      )
      )
    )
    (setq i (1+ i))
)
(setq l (f2 lst))
(setq      i0
      l0 lst
      d0 (get-closedpolygon-length lst)
)
(foreach a l
    (if      (and (< a _pi2) (setq p (nth i l0)))
      (progn
      (setq l1 (f1 p (vl-remove p lst)))
      (setq d1 (get-closedpolygon-length l1))
      (if (< d1 d0)
          (setq      d0d1
                lst l1
          )
      )
      )
    )
    (setq i (1+ i))
)
(entmake
    (append (list '(0 . "LWPOLYLINE")
                  '(100 . "AcDbEntity")
                  '(8 . "temp")
                  '(62 . 1)
                  '(100 . "AcDbPolyline")
                  (cons 90 (length lst))
                  '(70 . 1)
            )
            (mapcar (function (lambda (p) (cons 10 p))) lst)
    )
)
(setq t2 (getvar "MilliSecs"))
(princ (strcat "\nTSP Length :" (rtos d0 2 0) "."))
(princ (strcat "\nUse Time :" (rtos (- t2 t1) 2 0) "ms."))
(princ)
)
;;;Use Funtions
;;;--------------------------------------------------------------
;; Convex hull of pts , Graham scan method
;; by Highflybird
(defun Graham-scan (ptl / hPs rPs PsY Pt0 sPs P Q)
    (if      (< (length ptl) 4)                ;3点以下
      ptl                              ;是本集合
      (progn
      (setq rPs (mapcar (function (lambda (x)
                                    (if (= (length x) 3)
                                        (cdr x)      x)))
                        (mapcar 'reverse ptl));_点表的X和Y交换
            PsY (mapcar 'cadr ptl) ;_点表的Y值的表
            Pt0 (reverse (assoc (apply 'min PsY) rPs)) ;_最下面的点      
            sPs (sort-ad ptl Pt0) ;_按角度距离排序点集
            hPs (list (caddr sPs) (cadr sPs) Pt0) ;_开始的三点
      )
      (foreach n (cdddr sPs)                ;从第4点开始
          (setq      hPs (cons n hPs)      ;把Pi加入到凸集
                P   (cadr hPs)                ;Pi-1
                Q   (caddr hPs)                ;Pi-2
          )
          (while (and q (> (det n P Q) -1e-6)) ;如果左转
            (setq hPs (cons n (cddr hPs)) ;删除Pi-1点
                  P   (cadr hPs)      ;得到新的Pi-1点
                  Q   (caddr hPs)      ;得到新的Pi-2点
            )))
      hPs                              ;返回凸集
      ))
)
;;;以最下面的点为基点，按照角度和距离分类点集
(defun sort-ad (pl pt)
(vl-sort pl
         (function (lambda (e1 e2 / an1 an2)
               (setq an1 (angle pt e1)
                     an2 (angle pt e2))
               (if (equal an1 an2 1e-6);_这里降低误差，以适应工程需求
               (< (distance pt e1) (distance pt e2))
               (< an1 an2)
               ))))
)
;;定义三点的行列式,即三点之倍面积
(defun det (p1 p2 p3)
(- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
   (* (- (car p3) (car p1)) (- (cadr p2) (cadr p1)))
))
;;;
;;;------------------------
(defun my-getpt      (/ ss i en l)
(setq ss (ssget '((0 . "*line,LWPOLYLINE"))));;选择点
(setq i -1)
(while (setq en (ssname ss (setq i (1+ i))))
    (setq l (cons (cdr (assoc 10 (entget en))) l))
)
)
;;;------------------------
;;;
;;(ins-lst 10 5 '(1 2 3 4 5))
;; i 为新插入元素的位置
(defun ins-lst (new i lst / len fst)
(cond
    ((minusp i)
   lst
    )
    ((> i (setq len (length lst)))
   lst
    )
    ((> i (/ len 2))
   (reverse (ins-lst new (- len i) (reverse lst)))
    )
    (t
   (append
       (progn
         (setq fst nil)
         (repeat (rem i 4)
         (setq fst (cons (car lst) fst)
               lst (cdr lst)
         )
         )
         (repeat (/ i 4)
         (setq fst (cons (cadddr lst)
                           (cons (caddr lst)
                                 (cons
                                 (cadr lst)
                                 (cons
                                     (car lst)
                                     fst
                                 )
                                 )
                           )
                     )
               lst (cddddr lst)
         )
         )
         (reverse fst)
       )
       (list new)
       lst
   )
    )
)
)
;;;------------------------
;;
;;(ch-para-lst '(7 8 9) 3 '(1 2 3 4 5))
(defun ch-para-lst (para i lst / len fst)
(setq len (length lst))
(cond
    ((minusp i)
   lst
    )
    ((> i (1- len))
   lst
    )
    ((= i 0)
   (cons (cadr para)
         (cons (caddr para)
               (reverse (cons (car para) (cdr (reverse (cddr lst)))))
         )
   )
    )
    ((= i (1- len))
   (reverse
       (append (cdr (reverse para))
               (cddr (reverse (cons (last para) (cdr lst))))
       )
   )
    )
    ((> i (/ len 2))
   (reverse
       (ch-para-lst (reverse para) (- len i 1) (reverse lst))
   )
    )
    (t
   (append
       (progn
         (setq fst nil)
         (repeat (rem i 4)
         (setq fst (cons (car lst) fst)
               lst (cdr lst)
         )
         )
         (repeat (/ i 4)
         (setq fst (cons (cadddr lst)
                           (cons (caddr lst)
                                 (cons
                                 (cadr lst)
                                 (cons
                                     (car lst)
                                     fst
                                 )
                                 )
                           )
                     )
               lst (cddddr lst)
         )
         )
         (reverse
         (cons (caddr para)
               (cons (cadr para) (cons (car para) (cdr fst)))
         )
         )
       )
       (cdr lst)
   )
    )
)
)
;;;------------------------
;;
(defun get-minadddist-i      (lst p)
(car
    (vl-sort-i
      (mapcar (function      (lambda      (p1 p2)
                        (- (+ (distance p p1) (distance p p2))
                           (distance p1 p2)
                        )
                        )
            )
            (cons (last lst) lst)
            lst
      )
      '<
    )
)
)
;;;------------------------
(defun get-closest-i (lst p)
(car
    (vl-sort-i
      (mapcar
      (function
          (lambda (p1 p2 / pt d d1 d2)
            (setq pt (inters p
                           (polar p (+ (/ pi 2.) (angle p1 p2)) 1.)
                           p1
                           p2
                           nil
                     )
                  d(distance p1 p2)
                  d1 (distance p p1)
                  d2 (distance p p2)
            )
            (if      pt
            (if (equal (+ (distance pt p1) (distance pt p2)) d 1e-8)
                (distance p pt)
                d2
            )
            1e99
            )
          )
      )
      (cons (last lst) lst)
      lst
      )
      '<
    )
)
)
;;;------------------------
;;
(defun get-closedpolygon-length      (l)
(apply (function +)
         (mapcar (function (lambda (p1 p2)
                           (distance p1 p2)
                           )
               )
               (cons (last l) l)
               l
         )
)
)

357785513 发表于 2016-1-18 21:14:22

八楼的高手，为什么 有的会是反的呀，难道是起点的原因

香田里浪人 发表于 2016-1-19 10:33:23

本帖最后由 香田里浪人 于 2016-1-19 10:39 编辑

357785513 发表于 2016-1-18 21:14 http://bbs.mjtd.com/static/image/common/back.gif
八楼的高手，为什么 有的会是反的呀，难道是起点的原因

我不是什么高手，程序是偷来的，是的，该程序是与画线起点有关，仅考虑起点，未考虑其他（如终点）。

查看完整版本: 我经常要做这样的事