[分享]宽PL线转线框，PL线剪影

chlh_jd · 发表于 2010-8-9 14:53:00

本帖最后由作者于 2010-8-31 21:36:52 编辑

                              宽LWPOLYLINE转线框，相当于剪影功能
   采用纯VLISP方式实现将宽度>0的LWPOLYLINE转线框，对圆弧段采用3段圆弧模拟。

file:///D://PPL.bmp

   源码如下：
主框架源码

;;;------------------------------------------------------------------------;;;
;;;宽POLYLINE转线框程序
(defun c:PPL (/ ssen)
(setq ssen (wjm_ss2lst (ssget (list (cons 0 "LWPOLYLINE")))))
(foreach a ssen
(ss-WPL->PL a T)
(entdel a)
)
(princ "\n高山流水宽PL线转线框程序,命令PPL")
(princ)
)
;;;------------------------------------------------------------------------;;;
(defun c:PPL1 (/ ssen)
(setq ssen (wjm_ss2lst (ssget (list (cons 0 "LWPOLYLINE")))))
(foreach a ssen
(ss-WPL->PL a NIL)
(entdel a)
)
(princ "\n高山流水宽PL线转单段线框程序,命令PPL1")
(princ)
)
;;; ---------------------------------------------------------------------------;;;
;;; SS-WPL->PL ;;;
;;; ---------------------------------------------------------------------------;;;
;;; function : Translate Wide LwPolyLine into Frame Border ;;;
;;; Arg : ;;;
;;; pl - PL Ename ;;;
;;; bool - boolean, T or NIL ;;;
;;; If you provide T , Then it'll translate PL to a Closed PL-Frame, ;;;
;;; If it's NIL , Single-stage PL-Frame. ;;;
;;; GE Alg : ;;;
;;; Trisect ARC length and width, Combine sidelines with Convexity ;;;
;;; ---------------------------------------------------------------------------;;;
;;; Example: ;;;
;;; (SS-WPL->PL PL_Ename T) ;_Return a Closed PL-Frame ;;;
;;; ---------------------------------------------------------------------------;;;
;;; Writen By GSLS(SS) 2010-08-08 ;;;
;;; (C) EasyCity OptDesign Studio of Building Structures ;;;
;;; Email: chlh_jd@126.com Tel:0592-5391029 Fax:0592-5391020 ;;;
;;; ---------------------------------------------------------------------------;;;
(defun SS-WPL->PL (pl bool)
(if bool
;;;整条返回封闭POLYLINE
(mapcar 'entmake (ss-PL->Bound pl))
;;;逐段返回封闭POLYLINE
(ss-pl->sbound pl)
)
)

;;;------------------------------------------------------------------------;;; 
;;;宽POLYLINE转线框程序 
(defun c:PPL (/ ssen) 
(setq ssen (wjm_ss2lst (ssget (list (cons 0 "LWPOLYLINE"))))) 
(foreach a ssen 
(ss-WPL->PL a T) 
(entdel a) 
) 
(princ "\n高山流水宽PL线转线框程序,命令PPL") 
(princ) 
) 
;;;------------------------------------------------------------------------;;; 
(defun c:PPL1 (/ ssen) 
(setq ssen (wjm_ss2lst (ssget (list (cons 0 "LWPOLYLINE"))))) 
(foreach a ssen 
(ss-WPL->PL a NIL) 
(entdel a) 
) 
(princ "\n高山流水宽PL线转单段线框程序,命令PPL1") 
(princ) 
) 
;;; ---------------------------------------------------------------------------;;; 
;;; SS-WPL->PL ;;; 
;;; ---------------------------------------------------------------------------;;; 
;;; function : Translate Wide LwPolyLine into Frame Border ;;; 
;;; Arg : ;;; 
;;; pl - PL Ename ;;; 
;;; bool - boolean, T or NIL ;;; 
;;; If you provide T , Then it'll translate PL to a Closed PL-Frame, ;;; 
;;; If it's NIL , Single-stage PL-Frame. ;;; 
;;; GE Alg : ;;; 
;;; Trisect ARC length and width, Combine sidelines with Convexity ;;; 
;;; ---------------------------------------------------------------------------;;; 
;;; Example: ;;; 
;;; (SS-WPL->PL PL_Ename T) ;_Return a Closed PL-Frame ;;; 
;;; ---------------------------------------------------------------------------;;; 
;;; Writen By GSLS(SS) 2010-08-08 ;;; 
;;; (C) EasyCity OptDesign Studio of Building Structures ;;; 
;;; Email: chlh_jd@126.com Tel:0592-5391029 Fax:0592-5391020 ;;; 
;;; ---------------------------------------------------------------------------;;; 
(defun SS-WPL->PL (pl bool) 
(if bool 
;;;整条返回封闭POLYLINE 
(mapcar 'entmake (ss-PL->Bound pl)) 
;;;逐段返回封闭POLYLINE 
(ss-pl->sbound pl) 
) 
)

主函数源码1:

(defun SS-PL->Bound (pl / ent is_close pl_vetex
b i lst1 lst2 w02 c0 p1
p2 w11 w12 c1 b mid mid1
mid2 mid3 mid4 mid5 mid6 from1 from2
mpt1 mpt2 m1 m2 mpt1 mpt2 ang
dis1 dis2 mptl1 mptr1 mptl2 mptr2 n1
n2 m3 m4 end
)
(setq ent (entget pl '("*")))
(setq is_close (rem (cdr (assoc 70 ent)) 2))
(setq pl_vetex nil
b nil
)
(foreach n ent ;_(setq e (assoc 10 ent))
(if (or (= 10 (car n))
(= 40 (car n))
(= 41 (car n))
(= 42 (car n))
) ;_ 结束or
(progn
(setq b (cons (cdr n) b))
(if (= 4 (length b))
(setq pl_vetex (append pl_vetex (list (reverse b)))
b nil
)
)
)
)
)
(setq i 0
lst1 nil
lst2 nil
w02 nil
c0 nil
)
(foreach a pl_vetex
(setq p1 (car a)
w11 (cadr a)
w12 (caddr a)
c1 (cadddr a)
b (nth (1+ i) pl_vetex)
mid nil
mid1 nil
mid2 nil
from1 nil
form2 nil
)
(if (and (null b) (= is_close 1))
(setq b (car pl_vetex))
)
(if (setq p2 (car b))
(progn
(setq mid (ss-plwk-pts p1 w11 w12 c1 p2))
(if
(or (null c0) (null w02)) ;_第一段
(repeat (/ (length mid) 2)
(setq lst1 (cons (car mid) lst1)
lst2 (cons (cadr mid) lst2)
mid (cddr mid)
)
)
(progn
(setq from1 (car lst1)
lst1 (cdr lst1)
from2 (car lst2)
lst2 (cdr lst2)
)
(cond
;;;
;;;_1同为直段
((= c0 c1 0.0)
(setq mid1 (car mid)
mid2 (cadr mid)
)
(cond
((= w02 w11)
(if (setq mpt1 (inters (car from1)
(cadr from1)
(car mid1)
(cadr mid1)
nil
)
)
(progn
(setq mpt2 (inters (car from2)
(cadr from2)
(car mid2)
(cadr mid2)
nil
)
)
;;_无需再次判别连接
(setq lst1 (cons (ch-lst mpt1 1 from1) lst1)
lst2 (cons (ch-lst mpt2 1 from2) lst2)
lst1 (cons (ch-lst mpt1 0 mid1) lst1)
lst2 (cons (ch-lst mpt2 0 mid2) lst2)
)
)
(setq lst1 (cons mid1 (cons from1 lst1))
lst2 (cons mid2 (cons from2 lst2))
)
)
) ;_end cond 2.1
((> w02 w11) ;_前宽后窄
(setq mpt1 (inters (car mid1)
(cadr mid1)
(car from1)
(cadr from1)
nil
)
mpt2 (inters (car mid2)
(cadr mid2)
(car from2)
(cadr from2)
nil
)
) ;_(check-pt (list mpt1 mpt2))
(if (and mpt1 mpt2) ;_不存在交点，则平行
(progn ;_存在交点
;_有个问题，是取宽端点连线交点，还是取与宽边交点？??????????????????????????????????????????
;_暂时按方向角改变在[- pi/6 pi/6]
(if
(or
(<=
(/ pi -6.0)
(- (gsls-ang-trans
(angle
(midpt (car from1) (car from2))
(midpt (cadr from1) (cadr from2))
)
)
(gsls-ang-trans
(angle (midpt (car mid1) (car mid2))
(midpt (cadr mid1) (cadr mid2))
)
)
)
(/ pi 6.0)
)
(/= w01 0.0)
)
(setq mpt1 (inters (cadr from1)
(cadr from2)
(car mid1)
(cadr mid1)
nil
)
mpt2 (inters (cadr from1)
(cadr from2)
(car mid2)
(cadr mid2)
nil
)
lst1 (cons (ch-lst mpt1 0 mid1)
(cons from1 lst1)
)
lst2 (cons (ch-lst mpt2 0 mid2)
(cons from2 lst2)
)
)
(setq
mid1 (ch-lst mpt1 0 mid1)
mid2 (ch-lst mpt2 0 mid2)
from1 (ch-lst mpt1 1 from1)
from2 (ch-lst mpt2 1 from2)
lst1 (cons mid1 (cons from1 lst1))
lst2 (cons mid2 (cons from2 lst2))
)
)
)
;;_平行
(setq lst1 (cons mid1 (cons from1 lst1))
lst2 (cons mid2 (cons from2 lst2))
)
)
)
((< w02 w11)
(setq mpt1 (inters (car mid1)
(cadr mid1)
(car from1)
(cadr from1)
nil
)
mpt2 (inters (car mid2)
(cadr mid2)
(car from2)
(cadr from2)
nil
)
)
(if (and mpt1 mpt2) ;_不存在交点，则平行
(progn ;_存在交点
;_有个问题，是取宽端点连线交点，还是取与宽边交点？??????????????????????????????????????????
;_暂时按方向角改变在[- pi/6 pi/6]
(if (<= (/ pi -6.0)
(- (gsls-ang-trans
(angle (car from1) (cadr from1))
)
(gsls-ang-trans
(angle (car mid1) (cadr mid1))
)
)
(/ pi 6.0)
)
(setq mpt1 (inters (car from1)
(cadr from2)
(car mid1)
(car mid2)
nil
)
mpt2 (inters (car from1)
(cadr from2)
(car mid1)
(car mid2)
nil
)
lst1 (cons mid1
(cons (ch-lst mpt1 1 from1) lst1)
)
lst2 (cons mid2
(cons (ch-lst mpt2 1 from2) lst2)
)
)
(setq mpt1 (inters (car mid1)
(cadr mid1)
(car from1)
(cadr from1)
nil
)
mpt2 (inters (car mid2)
(cadr mid2)
(car from2)
(cadr from2)
nil
)
mid1 (ch-lst mpt1 0 mid1)
mid2 (ch-lst mpt2 0 mid2)
from1 (ch-lst mpt1 1 from1)
from2 (ch-lst mpt2 1 from2)
lst1 (cons mid1 (cons from1 lst1))
lst2 (cons mid2 (cons from2 lst2))
)
)
)
;_平行
(setq lst1 (cons mid1 (cons from1 lst1))
lst2 (cons mid2 (cons from2 lst2))
)
) ;_end if
) ;_前窄后宽
)
)
;;;
;;;_2前段直段，后段弧
((and (= c0 0.0) (/= c1 0.0))
;(check-pt (cdr (reverse from1)))
(setq mid1 (car mid)
mid2 (cadr mid)
mid (cddr mid)
mid3 (car mid)
mid4 (cadr mid)
mid (cddr mid)
mid5 (car mid)
mid6 (cadr mid)
m1 (SS-PTC-ptcR
(car mid1)
(cadr mid1)
(caddr mid1)
)
m2 (SS-PTC-ptcR
(car mid2)
(cadr mid2)
(caddr mid2)
)
m3 (SS-PTC-ptcR
p1
p2
c1
)
mpt1 (get-mindis-pt (ss-pl-inters from1 mid1) p1)
mpt2 (get-mindis-pt (ss-pl-inters from2 mid2) p1) ;_(check-pt (list (car from2) (cadr from2)))
)
(cond
((= w02 w11) ;_2.1等宽
(if (or mpt1 mpt2)
(progn
(if mpt1
nil
(setq mpt1
(get-mindis-pt
(ss-pl-inters from1 (list p1 mpt2 0.0))
p1
)
)
)
(if mpt2
nil
(setq mpt2
(get-mindis-pt
(ss-pl-inters from2 (list p1 mpt1 0.0))
p1
)
)
)
)
(progn
(setq
mpt1 (pedal_to_line
(car m1)
(car from1)
(cadr from1)
)
mpt2 (pedal_to_line
(car m2)
(car from2)
(cadr from2)
)
ang (angle (car from1) (cadr from1))
)
(if
(equal (cadr m1)
(distance (car m1) mpt1)
2e-6
)
(setq dis1 0.0)
(setq
dis1
(sqrt (- (expt (cadr m1) 2.0)
(expt (distance (car m1) mpt1) 2.0)
)
)
)
)
(if
(equal (cadr m2)
(distance (car m2) mpt2)
2e-6
)
(setq dis2 0.0)
(setq
dis2
(sqrt (- (expt (cadr m2) 2.0)
(expt (distance (car m2) mpt2) 2.0)
)
)
)
)
(setq
mptl1 (polar mpt1 (+ ang pi) dis1)
mptr1 (polar mpt1 ang dis1)
mptl2 (polar mpt2 (+ ang pi) dis2)
mptr2 (polar mpt2 ang dis2)
)
(cond ((> (distance mptl1 (car mid1))
(distance mptr1 (car mid1))
)
(setq mpt1 mptr1)
)
((< (distance mptl1 (car mid1))
(distance mptr1 (car mid1))
)
(setq mpt1 mptl1)
)
(t
(setq mpt1 (midpt mptl1 mptr1)) ;_这里需要推敲下,求中点消除误差
)
)
(cond ((> (distance mptl2 (car mid2))
(distance mptr2 (car mid2))
)
(setq mpt2 mptr2)
)
((< (distance mptl2 (car mid2))
(distance mptr2 (car mid2))
)
(setq mpt2 mptl2)
)
(t
(setq mpt2 (midpt mptl2 mptr2))
)
)
)
)
(setq n1 (ss-ptc-c mpt1
(cadr mid1)
(car m1)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m2)
(> (caddr mid2) 0.0)
)
)
(setq lst1 (cons (ch-lst
mpt1
1
from1
)
lst1
) ;_
lst2 (cons (ch-lst
mpt2
1
from2
)
lst2
) ;_
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
)
((> w02 w11) ;_2.2前宽后窄
;_(command "line" (list 0 0 0) mpt2 "")
(setq mpt1 (get-mindis-pt
(ss-pl-inters
(list (cadr from1) (cadr from2) 0.0)
mid1
)
(car mid1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
(list (cadr from1) (cadr from2) 0.0)
mid2
)
(car mid2)
)
)
(if (and mpt1 mpt2) ;_这里需要调整下，可能存在一个交点，也是符合第一项处理
(progn
(setq n1 (ss-ptc-c mpt1
(cadr mid1)
(car m1)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m2)
(> (caddr mid2) 0.0)
)
)
(setq lst1 (cons from1 lst1)
lst2 (cons from2 lst2)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
)
(progn
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
mid1
)
(car mid1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
mid2
)
(car mid2)
)
)
(setq n1 (ss-ptc-c mpt1
(cadr mid1)
(car m1)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m2)
(> (caddr mid2) 0.0)
)
)
(setq from1 (ch-lst mpt1 1 from1)
from2 (ch-lst mpt2 1 from2)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons from1 lst1)
lst2 (cons from2 lst2)
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
)
)
)
((< w02 w11) ;_2.3前窄后款
(setq mpt1 (car (ss-pl-inters
from1
(list (car mid1) (car mid2) 0.0)
)
)
mpt2 (car (ss-pl-inters
from2
(list (car mid1) (car mid2) 0.0)
)
)
)
(if (and mpt1 mpt2)
(setq lst1 (cons (ch-lst
mpt1
1
from1
)
lst1
)
lst2 (cons (ch-lst
mpt2
1
from2
)
lst2
)
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
mid1
)
(car mid1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
mid2
)
(car mid2)
)
n1 (ss-ptc-c mpt1
(cadr mid1)
(car m1)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m2)
(> (caddr mid2) 0.0)
)
from1 (ch-lst mpt1 1 from1)
from2 (ch-lst mpt2 1 from2)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons mid1 (cons from1 lst1))
lst (cons mid2 (cons from2 lst1))
)
)
)
)
(setq
lst1
(cons mid5 (cons mid3 lst1))
lst2
(cons mid6 (cons mid4 lst2))
)
) ;_end 2.前直后弧
;;;
;;;_3前段弧段，后段直
((and (/= c0 0.0) (= c1 0.0))
(setq mid1 (car mid)
mid2 (cadr mid)
m1 (SS-PTC-ptcR
(car from1)
(cadr from1)
(caddr from1)
)
m2 (SS-PTC-ptcR
(car from2)
(cadr from2)
(caddr from2)
)
m3 (SS-PTC-ptcR
(midpt (car from1) (car from2))
(midpt (cadr from1) (cadr from2))
(/ (+ (caddr from1) (caddr from2)) 2.0)
)
mpt1 (get-mindis-pt (ss-pl-inters from1 mid1) p1)
mpt2 (get-mindis-pt (ss-pl-inters from2 mid2) p1)
)
(cond
((= w02 w11) ;_3.1等宽这段代码需要改进，思路不清晰,用了开方，容差性差
(setq
mpt1 (pedal_to_line
(car m1)
(car mid1)
(cadr mid1)
)
mpt2 (pedal_to_line
(car m2)
(car mid2)
(cadr mid2)
)
ang (angle (car mid1) (cadr mid1))
)
(if (equal (cadr m1) (distance (car m1) mpt1) 2e-6)
(setq dis1 0.0)
(setq
dis1
(sqrt (- (expt (cadr m1) 2.0)
(expt (distance (car m1) mpt1) 2.0)
)
)
)
)
(if (equal (cadr m2) (distance (car m2) mpt2) 2e-6)
(setq dis2 0.0)
(setq
dis2
(sqrt (- (expt (cadr m2) 2.0)
(expt (distance (car m2) mpt2) 2.0)
)
)
)
)
(setq
mptl1 (polar mpt1 (+ ang pi) dis1)
mptr1 (polar mpt1 ang dis1)
mptl2 (polar mpt2 (+ ang pi) dis2)
mptr2 (polar mpt2 ang dis2)
)
(cond ((> (distance mptl1 (cadr from1))
(distance mptr1 (cadr from1))
)
(setq mpt1 mptr1)
)
((< (distance mptl1 (cadr from1))
(distance mptr1 (cadr from1))
)
(setq mpt1 mptl1)
)
(t
(setq mpt1 (midpt mptl1 mptr1))
)
)
(cond ((> (distance mptl2 (cadr from2))
(distance mptr2 (cadr from2))
)
(setq mpt2 mptr2)
)
((< (distance mptl2 (cadr from2))
(distance mptr2 (cadr from2))
)
(setq mpt2 mptl2)
)
(t
(setq mpt2 (midpt mptl2 mptr2))
)
)
)
((> w02 w11) ;_3.2前宽后窄
(setq mpt1 (inters (cadr from1)
(cadr from2)
(car mid1)
(cadr mid1)
nil
)
mpt2 (inters (cadr from1)
(cadr from2)
(car mid2)
(cadr mid2)
nil
)
)
(if (and mpt1 mpt2)
nil
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
mid1
)
(cadr from1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
mid2
)
(cadr from2)
)
)
)
)
((< w02 w11) ;_3.3前窄后宽
(setq mpt1 (get-mindis-pt
(ss-pl-inters
(list (car mid1) (car mid2) 0.0)
from1
)
(cadr from1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
(list (car mid1) (car mid2) 0.0)
from2
)
(cadr from2)
)
) ;_(command "line" (list 0 0) mpt2 "")
(if (and mpt1 mpt2)
nil
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
mid1
)
(cadr from1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
mid2
)
(cadr from2)
)
)
)
) ;_3.3
) ;_end cond
(setq
n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
n2 (ss-ptc-c
(car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
lst1 (cons (ch-lst n1 2 (ch-lst mpt1 1 from1))
lst1
)
lst2 (cons (ch-lst n2 2 (ch-lst mpt2 1 from2))
lst2
)
mid1 (ch-lst mpt1 0 mid1)
mid2 (ch-lst mpt2 0 mid2)
lst1 (cons mid1 lst1) ;_(check-pt (list mpt1 mpt2))
lst2 (cons mid2 lst2)
)
) ;_end 3.前弧后直
;;;
;;;_4.前段弧，后段弧
((and (/= c0 0.0) (/= c1 0.0))
(setq mid1 (car mid)
mid2 (cadr mid)
mid (cddr mid)
mid3 (car mid)
mid4 (cadr mid)
mid (cddr mid)
mid5 (car mid)
mid6 (cadr mid)
m1 (SS-PTC-ptcR
(car from1)
(cadr from1)
(caddr from1)
)
m2 (SS-PTC-ptcR
(car from2)
(cadr from2)
(caddr from2)
)
m3 (SS-PTC-ptcR
(car mid1)
(cadr mid1)
(caddr mid1)
)
m4 (SS-PTC-ptcR
(car mid2)
(cadr mid2)
(caddr mid2)
)
)
(cond ((= w02 w11) ;_4.1等宽
(setq mpt1 (get-mindis-pt
(ss-pl-inters from1 mid1)
(cadr from1)
)
mpt2
(get-mindis-pt
(ss-pl-inters from2 mid2)
(cadr from2)
)
) ;_有一种可能，因为计算误差，引起交点不存在的情况需要处理
(setq n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
n2 (ss-ptc-c
(car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
n1 (ss-ptc-c mpt1
(cadr mid1)
(car m3)
(> (caddr mid1) 0.0)
)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m4)
(> (caddr mid2) 0.0)
)
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons mid1 (cons from1 lst1))
lst2 (cons mid2 (cons from2 lst2))
)
)
((> w02 w11) ;_4.2前宽后窄
(setq mpt1 (get-mindis-pt
(ss-pl-inters
(list (cadr from1) (cadr from2) 0.0)
mid1
)
(car mid1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
(list (cadr from1) (cadr from2) 0.0)
mid2
)
(car mid2)
)
)
(if (and mpt1 mpt2)
(progn
(setq n1 (ss-ptc-c mpt1
(cadr mid1)
(car m3)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m4)
(> (caddr mid2) 0.0)
)
)
(setq lst1 (cons from1 lst1)
lst2 (cons from2 lst2)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
)
;_凸度同号，可能不存在交在宽者法边
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
mid1
)
(car mid1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
mid2
)
(car mid2)
) ;_(check-pt (list mpt1 mpt2))
n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
n2 (ss-ptc-c (car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
n1 (ss-ptc-c mpt1
(cadr mid1)
(car m3)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m4)
(> (caddr mid2) 0.0)
)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons from1 lst1)
lst2 (cons from2 lst2)
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
) ;_end if
)
((< w02 w11) ;_4.3前窄后宽
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
(list (car mid1) (car mid2) 0.0)
)
(cadr from1)
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
(list (car mid1) (car mid2) 0.0)
)
(cadr from2)
)
)
(if (and mpt1 mpt2)
(setq n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
n2 (ss-ptc-c (car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
lst1 (cons from1 lst1)
lst2 (cons from2 lst2)
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
;_凸度同号，可能不存在都交于宽者法边交点
(setq mpt1 (get-mindis-pt
(ss-pl-inters
from1
mid1
)
p1
)
mpt2 (get-mindis-pt
(ss-pl-inters
from2
mid2
)
p1
)
n1 (ss-ptc-c (car from1)
mpt1
(car m1)
(> (caddr from1) 0.0)
)
n2 (ss-ptc-c (car from2)
mpt2
(car m2)
(> (caddr from2) 0.0)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
n1 (ss-ptc-c mpt1
(cadr mid1)
(car m3)
(> (caddr mid1) 0.0)
)
n2 (ss-ptc-c mpt2
(cadr mid2)
(car m4)
(> (caddr mid2) 0.0)
)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (cons from1 lst1)
lst2 (cons from2 lst2)
lst1 (cons mid1 lst1)
lst2 (cons mid2 lst2)
)
) ;_end if
)
)
(setq
lst1
(cons mid5 (cons mid3 lst1))
lst2
(cons mid6 (cons mid4 lst2))
)
) ;_end cond 4
) ;_end cond
) ;_end pro
) ;_end if
) ;_end if pro
) ;_end if
(setq w02 w12
w01 w11
c0 c1
b nil
i (1+ i)
)
) ;_end foreach
;;;双环列表创建完毕
;;;
;;;首尾连接处理
(if (= is_close 1)
(progn
(setq from1 (car lst1)
mid1 (last lst1)
from2 (car lst2)
mid2 (last lst2)
)
(setq mpt1 (get-mindis-pt (ss-pl-inters from1 mid1) (car mid1)) ;_(command "LINE" (list 0 0 0) mpt2 "")
mpt2 (get-mindis-pt (ss-pl-inters from2 mid2) (car mid2))
)
(setq
n1 (if (= (caddr from1) 0.0)
0.0
(ss-ptc-c
(car from1)
mpt1
(car (SS-PTC-ptcR
(car from1)
(cadr from1)
(caddr from1)
)
)
(> (caddr from1) 0.0)
)
)
n2 (if (= (caddr from2) 0.0)
0.0
(ss-ptc-c (car from2)
mpt2
(car (SS-PTC-ptcR
(car from2)
(cadr from2)
(caddr from2)
)
)
(> (caddr from2) 0.0)
)
)
from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
n1 (if (= (caddr mid1) 0.0)
0.0
(ss-ptc-c mpt1
(cadr mid1)
(car (SS-PTC-ptcR
(car mid1)
(cadr mid1)
(caddr mid1)
)
)
(> (caddr mid1) 0.0)
)
)
n2 (if (= (caddr mid2) 0.0)
0.0
(ss-ptc-c mpt2
(cadr mid2)
(car (SS-PTC-ptcR
(car mid2)
(cadr mid2)
(caddr mid2)
)
)
(> (caddr mid2) 0.0)
)
)
mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
lst1 (ch-lst from1 0 lst1)
lst1 (reverse (ch-lst mid1 0 (reverse lst1)))
lst2 (ch-lst from2 0 lst2)
lst2 (reverse (ch-lst mid2 0 (reverse lst2)))
)
)
)
;;首尾连接处理完毕
;(setvar "osmode" 0) ;_测试用
(setq lst1 (reverse lst1)) ;_(command "line" (list 0 0 0) (nth 0 (nth 2 lst2)) "")
(if (= is_close 0)
(progn
(setq len (length lst1)
i 1
lst nil
)
(foreach a lst1
(if (< i len)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (car (nth i lst1)))
nil
(setq lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(setq
lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
(setq i (1+ i))
)
(setq i 1)
(foreach a lst2
(if (< i len)
(progn
(setq lst
(append
lst
(list (cons 10 (cadr a)) (cons 42 (* -1.0 (caddr a))))
)
)
(if (eq (car a) (cadr (nth i lst2)))
nil
(setq lst
(append lst (list (cons 10 (car a)) (cons 42 0.0)))
)
)
)
(progn
(setq lst (append lst
(list (cons 10 (cadr a))
(cons 42 (* -1.0 (caddr a)))
)
)
)
(setq
lst
(append lst (list (cons 10 (car a)) (cons 42 0.0)))
)
)
)
(setq i (1+ i))
)
(setq lst (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (/ (length lst) 2))
(cons 70 1)
(cons 43 0.0)
)
lst
)
) ;_(check-pt (ss-assoc 10 lst))
;(entmakex lst)
(setq end (list lst))
)
(progn
(setq len (length lst1)
i 1
lst nil
)
(foreach a lst1
(if (< i len)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (cadr (nth i lst1)))
nil
(setq lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (caar lst1))
nil
(setq
lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
)
(setq i (1+ i))
)
(setq lst (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (/ (length lst) 2))
(cons 70 1)
(cons 43 0.0)
)
lst
)
)
;(entmakex lst)
(setq i 1
lst2 (reverse lst2)
end (cons lst end)
lst nil
)
(foreach a lst2
(if (< i len)
(progn
(setq
lst
(append
lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (cadr (nth i lst2)))
nil
(setq lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
(progn
(setq
lst
(append lst
(list (cons 10 (car a)) (cons 42 (caddr a)))
)
)
(if (eq (cadr a) (caar lst2))
nil
(setq
lst
(append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
)
)
)
)
(setq i (1+ i))
)
(setq lst (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (/ (length lst) 2))
(cons 70 1)
(cons 43 0.0)
)
lst
)
)
(setq end (reverse (cons lst end)))
;(entmakex lst)
)
) ;_end if
end
)

(defun SS-PL->Bound (pl     /    ent   is_close pl_vetex
       b     i    lst1   lst2  w02 c0     p1
       p2     w11    w12   c1  b mid    mid1
       mid2   mid3   mid4   mid5  mid6 from1  from2
       mpt1   mpt2   m1   m2  mpt1 mpt2   ang
       dis1   dis2   mptl1  mptr1  mptl2 mptr2  n1
       n2     m3    m4   end
      )
  (setq ent (entget pl '("*")))
  (setq is_close (rem (cdr (assoc 70 ent)) 2))
  (setq pl_vetex nil
 b nil
  )
  (foreach n ent ;_(setq e (assoc 10 ent))
    (if (or (= 10 (car n))
     (= 40 (car n))
     (= 41 (car n))
     (= 42 (car n))
 ) ;_ 结束or
      (progn
 (setq b (cons (cdr n) b))
 (if (= 4 (length b))
   (setq pl_vetex (append pl_vetex (list (reverse b)))
  b  nil
   )
 )
      )
    )
  )
  (setq i    0
 lst1 nil
 lst2 nil
 w02  nil
 c0   nil
  )
  (foreach a pl_vetex   
    (setq p1 (car a)
   w11 (cadr a)
   w12 (caddr a)
   c1 (cadddr a)
   b (nth (1+ i) pl_vetex)
   mid nil
   mid1 nil
   mid2 nil
   from1 nil
   form2 nil
    )
    (if (and (null b) (= is_close 1))
      (setq b (car pl_vetex))
    )
    (if (setq p2 (car b))
      (progn
 (setq mid (ss-plwk-pts p1 w11 w12 c1 p2))
 (if
   (or (null c0) (null w02)) ;_第一段
    (repeat (/ (length mid) 2)
      (setq lst1 (cons (car mid) lst1)
     lst2 (cons (cadr mid) lst2)
     mid (cddr mid)
      )
    )
    (progn
      (setq from1 (car lst1)
     lst1  (cdr lst1)
     from2 (car lst2)
     lst2  (cdr lst2)
      )
      (cond
;;;
;;;_1同为直段                                                                            
        ((= c0 c1 0.0)
  (setq mid1 (car mid)
        mid2 (cadr mid)
  )
  (cond
    ((= w02 w11)
     (if (setq mpt1 (inters (car from1)
       (cadr from1)
       (car mid1)
       (cadr mid1)
       nil
      )
         )
       (progn
         (setq mpt2 (inters (car from2)
       (cadr from2)
       (car mid2)
       (cadr mid2)
       nil
      )
         )
         ;;_无需再次判别连接
         (setq lst1 (cons (ch-lst mpt1 1 from1) lst1)
        lst2 (cons (ch-lst mpt2 1 from2) lst2)
        lst1 (cons (ch-lst mpt1 0 mid1) lst1)
        lst2 (cons (ch-lst mpt2 0 mid2) lst2)
         )
       )
       (setq lst1 (cons mid1 (cons from1 lst1))
      lst2 (cons mid2 (cons from2 lst2))
       )
     )
    ) ;_end cond 2.1
    ((> w02 w11) ;_前宽后窄
     (setq mpt1 (inters (car mid1)
          (cadr mid1)
          (car from1)
          (cadr from1)
          nil
         )
    mpt2 (inters (car mid2)
          (cadr mid2)
          (car from2)
          (cadr from2)
          nil
         )
     ) ;_(check-pt (list mpt1 mpt2))     
     (if (and mpt1 mpt2) ;_不存在交点，则平行
       (progn ;_存在交点        
 ;_有个问题，是取宽端点连线交点，还是取与宽边交点？??????????????????????????????????????????
 ;_暂时按方向角改变在[- pi/6 pi/6]
         (if
    (or
      (<=
        (/ pi -6.0)
        (- (gsls-ang-trans
      (angle
        (midpt (car from1) (car from2))
        (midpt (cadr from1) (cadr from2))
      )
    )
    (gsls-ang-trans
      (angle (midpt (car mid1) (car mid2))
      (midpt (cadr mid1) (cadr mid2))
      )
    )
        )
        (/ pi 6.0)
      )
      (/= w01 0.0)
    )
     (setq mpt1 (inters (cadr from1)
          (cadr from2)
          (car mid1)
          (cadr mid1)
          nil
         )
    mpt2 (inters (cadr from1)
          (cadr from2)
          (car mid2)
          (cadr mid2)
          nil
         )
    lst1 (cons (ch-lst mpt1 0 mid1)
        (cons from1 lst1)
         )
    lst2 (cons (ch-lst mpt2 0 mid2)
        (cons from2 lst2)
         )
     )
     (setq
       mid1  (ch-lst mpt1 0 mid1)
       mid2  (ch-lst mpt2 0 mid2)
       from1 (ch-lst mpt1 1 from1)
       from2 (ch-lst mpt2 1 from2)
       lst1  (cons mid1 (cons from1 lst1))
       lst2  (cons mid2 (cons from2 lst2))
     )
         )
       )
       ;;_平行
       (setq lst1 (cons mid1 (cons from1 lst1))
      lst2 (cons mid2 (cons from2 lst2))
       )
     )
    )
    ((< w02 w11)
     (setq mpt1 (inters (car mid1)
          (cadr mid1)
          (car from1)
          (cadr from1)
          nil
         )
    mpt2 (inters (car mid2)
          (cadr mid2)
          (car from2)
          (cadr from2)
          nil
         )
     )
     (if (and mpt1 mpt2) ;_不存在交点，则平行
       (progn ;_存在交点         
 ;_有个问题，是取宽端点连线交点，还是取与宽边交点？??????????????????????????????????????????
 ;_暂时按方向角改变在[- pi/6 pi/6]
         (if (<= (/ pi -6.0)
          (- (gsls-ang-trans
        (angle (car from1) (cadr from1))
      )
      (gsls-ang-trans
        (angle (car mid1) (cadr mid1))
      )
          )
          (/ pi 6.0)
      )
    (setq mpt1 (inters (car from1)
         (cadr from2)
         (car mid1)
         (car mid2)
         nil
        )
          mpt2 (inters (car from1)
         (cadr from2)
         (car mid1)
         (car mid2)
         nil
        )
          lst1 (cons mid1
       (cons (ch-lst mpt1 1 from1) lst1)
        )
          lst2 (cons mid2
       (cons (ch-lst mpt2 1 from2) lst2)
        )
    )
    (setq mpt1  (inters (car mid1)
          (cadr mid1)
          (car from1)
          (cadr from1)
          nil
         )
          mpt2  (inters (car mid2)
          (cadr mid2)
          (car from2)
          (cadr from2)
          nil
         )
          mid1  (ch-lst mpt1 0 mid1)
          mid2  (ch-lst mpt2 0 mid2)
          from1 (ch-lst mpt1 1 from1)
          from2 (ch-lst mpt2 1 from2)
          lst1  (cons mid1 (cons from1 lst1))
          lst2  (cons mid2 (cons from2 lst2))
    )
         )
       )
 ;_平行         
       (setq lst1 (cons mid1 (cons from1 lst1))
      lst2 (cons mid2 (cons from2 lst2))
       )
     ) ;_end if
    ) ;_前窄后宽
  )
        )
;;;
;;;_2前段直段，后段弧                                                                  
        ((and (= c0 0.0) (/= c1 0.0))
     ;(check-pt (cdr (reverse from1)))
  (setq mid1 (car mid)
        mid2 (cadr mid)
        mid  (cddr mid)
        mid3 (car mid)
        mid4 (cadr mid)
        mid  (cddr mid)
        mid5 (car mid)
        mid6 (cadr mid)
        m1   (SS-PTC-ptcR
        (car mid1)
        (cadr mid1)
        (caddr mid1)
      )
        m2   (SS-PTC-ptcR
        (car mid2)
        (cadr mid2)
        (caddr mid2)
      )
        m3   (SS-PTC-ptcR
        p1
        p2
        c1
      )
        mpt1 (get-mindis-pt (ss-pl-inters from1 mid1) p1)
        mpt2 (get-mindis-pt (ss-pl-inters from2 mid2) p1) ;_(check-pt (list (car from2) (cadr from2)))
  )
  (cond
    ((= w02 w11) ;_2.1等宽  
     (if (or mpt1 mpt2)
       (progn
         (if mpt1
    nil
    (setq mpt1
    (get-mindis-pt
      (ss-pl-inters from1 (list p1 mpt2 0.0))
      p1
    )
    )
         )
         (if mpt2
    nil
    (setq mpt2
    (get-mindis-pt
      (ss-pl-inters from2 (list p1 mpt1 0.0))
      p1
    )
    )
         )
       )
       (progn
         (setq
    mpt1 (pedal_to_line
    (car m1)
    (car from1)
    (cadr from1)
         )
    mpt2 (pedal_to_line
    (car m2)
    (car from2)
    (cadr from2)
         )
    ang  (angle (car from1) (cadr from1))
         )
         (if
    (equal (cadr m1)
    (distance (car m1) mpt1)
    2e-6
    )
     (setq dis1 0.0)
     (setq
       dis1
        (sqrt (- (expt (cadr m1) 2.0)
          (expt (distance (car m1) mpt1) 2.0)
       )
        )
     )
         )
         (if
    (equal (cadr m2)
    (distance (car m2) mpt2)
    2e-6
    )
     (setq dis2 0.0)
     (setq
       dis2
        (sqrt (- (expt (cadr m2) 2.0)
          (expt (distance (car m2) mpt2) 2.0)
       )
        )
     )
         )
         (setq
    mptl1 (polar mpt1 (+ ang pi) dis1)
    mptr1 (polar mpt1 ang dis1)
    mptl2 (polar mpt2 (+ ang pi) dis2)
    mptr2 (polar mpt2 ang dis2)
         )
         (cond ((> (distance mptl1 (car mid1))
     (distance mptr1 (car mid1))
         )
         (setq mpt1 mptr1)
        )
        ((< (distance mptl1 (car mid1))
     (distance mptr1 (car mid1))
         )
         (setq mpt1 mptl1)
        )
        (t
         (setq mpt1 (midpt mptl1 mptr1)) ;_这里需要推敲下,求中点消除误差
        )
         )
         (cond ((> (distance mptl2 (car mid2))
     (distance mptr2 (car mid2))
         )
         (setq mpt2 mptr2)
        )
        ((< (distance mptl2 (car mid2))
     (distance mptr2 (car mid2))
         )
         (setq mpt2 mptl2)
        )
        (t
         (setq mpt2 (midpt mptl2 mptr2))
        )
         )
       )
     )
     (setq n1 (ss-ptc-c mpt1
          (cadr mid1)
          (car m1)
          (> (caddr mid1) 0.0)
       )
    n2 (ss-ptc-c mpt2
          (cadr mid2)
          (car m2)
          (> (caddr mid2) 0.0)
       )
     )
     (setq lst1 (cons (ch-lst
          mpt1
          1
          from1
        )
        lst1
         ) ;_
    lst2 (cons (ch-lst
          mpt2
          1
          from2
        )
        lst2
         ) ;_
    mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
    mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
    lst1 (cons mid1 lst1)
    lst2 (cons mid2 lst2)
     )
    )
    ((> w02 w11) ;_2.2前宽后窄                                                         
 ;_(command "line" (list 0 0 0) mpt2 "")
     (setq mpt1 (get-mindis-pt
    (ss-pl-inters
      (list (cadr from1) (cadr from2) 0.0)
      mid1
    )
    (car mid1)
         )
    mpt2 (get-mindis-pt
    (ss-pl-inters
      (list (cadr from1) (cadr from2) 0.0)
      mid2
    )
    (car mid2)
         )
     )
     (if (and mpt1 mpt2) ;_这里需要调整下，可能存在一个交点，也是符合第一项处理
       (progn
         (setq n1 (ss-ptc-c mpt1
       (cadr mid1)
       (car m1)
       (> (caddr mid1) 0.0)
    )
        n2 (ss-ptc-c mpt2
       (cadr mid2)
       (car m2)
       (> (caddr mid2) 0.0)
    )
         )
         (setq lst1 (cons from1 lst1)
        lst2 (cons from2 lst2)
        mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
        mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
        lst1 (cons mid1 lst1)
        lst2 (cons mid2 lst2)
         )
       )
       (progn
         (setq mpt1 (get-mindis-pt
        (ss-pl-inters
          from1
          mid1
        )
        (car mid1)
      )
        mpt2 (get-mindis-pt
        (ss-pl-inters
          from2
          mid2
        )
        (car mid2)
      )
         )
         (setq n1 (ss-ptc-c mpt1
       (cadr mid1)
       (car m1)
       (> (caddr mid1) 0.0)
    )
        n2 (ss-ptc-c mpt2
       (cadr mid2)
       (car m2)
       (> (caddr mid2) 0.0)
    )
         )
         (setq from1 (ch-lst mpt1 1 from1)
        from2 (ch-lst mpt2 1 from2)
        mid1  (ch-lst n1 2 (ch-lst mpt1 0 mid1))
        mid2  (ch-lst n2 2 (ch-lst mpt2 0 mid2))
        lst1  (cons from1 lst1)
        lst2  (cons from2 lst2)
        lst1  (cons mid1 lst1)
        lst2  (cons mid2 lst2)
         )
       )
     )
    )
    ((< w02 w11) ;_2.3前窄后款
     (setq mpt1 (car (ss-pl-inters
         from1
         (list (car mid1) (car mid2) 0.0)
       )
         )
    mpt2 (car (ss-pl-inters
         from2
         (list (car mid1) (car mid2) 0.0)
       )
         )
     )
     (if (and mpt1 mpt2)
       (setq lst1 (cons (ch-lst
     mpt1
     1
     from1
          )
          lst1
    )
      lst2 (cons (ch-lst
     mpt2
     1
     from2
          )
          lst2
    )
      lst1 (cons mid1 lst1)
      lst2 (cons mid2 lst2)
       )
       (setq mpt1  (get-mindis-pt
       (ss-pl-inters
         from1
         mid1
       )
       (car mid1)
     )
      mpt2  (get-mindis-pt
       (ss-pl-inters
         from2
         mid2
       )
       (car mid2)
     )
      n1  (ss-ptc-c mpt1
        (cadr mid1)
        (car m1)
        (> (caddr mid1) 0.0)
     )
      n2  (ss-ptc-c mpt2
        (cadr mid2)
        (car m2)
        (> (caddr mid2) 0.0)
     )
      from1 (ch-lst mpt1 1 from1)
      from2 (ch-lst mpt2 1 from2)
      mid1  (ch-lst n1 2 (ch-lst mpt1 0 mid1))
      mid2  (ch-lst n2 2 (ch-lst mpt2 0 mid2))
      lst1  (cons mid1 (cons from1 lst1))
      lst  (cons mid2 (cons from2 lst1))
       )
     )
    )
  )
  (setq
    lst1
         (cons mid5 (cons mid3 lst1))
    lst2
         (cons mid6 (cons mid4 lst2))
  )
        ) ;_end 2.前直后弧
;;;
;;;_3前段弧段，后段直                                                                                 
        ((and (/= c0 0.0) (= c1 0.0))
  (setq mid1 (car mid)
        mid2 (cadr mid)
        m1   (SS-PTC-ptcR
        (car from1)
        (cadr from1)
        (caddr from1)
      )
        m2   (SS-PTC-ptcR
        (car from2)
        (cadr from2)
        (caddr from2)
      )
        m3   (SS-PTC-ptcR
        (midpt (car from1) (car from2))
        (midpt (cadr from1) (cadr from2))
        (/ (+ (caddr from1) (caddr from2)) 2.0)
      )
        mpt1 (get-mindis-pt (ss-pl-inters from1 mid1) p1)
        mpt2 (get-mindis-pt (ss-pl-inters from2 mid2) p1)
  )
  (cond
    ((= w02 w11) ;_3.1等宽 这段代码需要改进，思路不清晰,用了开方，容差性差
     (setq
       mpt1 (pedal_to_line
       (car m1)
       (car mid1)
       (cadr mid1)
     )
       mpt2 (pedal_to_line
       (car m2)
       (car mid2)
       (cadr mid2)
     )
       ang  (angle (car mid1) (cadr mid1))
     )
     (if (equal (cadr m1) (distance (car m1) mpt1) 2e-6)
       (setq dis1 0.0)
       (setq
         dis1
   (sqrt (- (expt (cadr m1) 2.0)
     (expt (distance (car m1) mpt1) 2.0)
         )
   )
       )
     )
     (if (equal (cadr m2) (distance (car m2) mpt2) 2e-6)
       (setq dis2 0.0)
       (setq
         dis2
   (sqrt (- (expt (cadr m2) 2.0)
     (expt (distance (car m2) mpt2) 2.0)
         )
   )
       )
     )
     (setq
       mptl1 (polar mpt1 (+ ang pi) dis1)
       mptr1 (polar mpt1 ang dis1)
       mptl2 (polar mpt2 (+ ang pi) dis2)
       mptr2 (polar mpt2 ang dis2)
     )
     (cond ((> (distance mptl1 (cadr from1))
        (distance mptr1 (cadr from1))
     )
     (setq mpt1 mptr1)
    )
    ((< (distance mptl1 (cadr from1))
        (distance mptr1 (cadr from1))
     )
     (setq mpt1 mptl1)
    )
    (t
     (setq mpt1 (midpt mptl1 mptr1))
    )
     )
     (cond ((> (distance mptl2 (cadr from2))
        (distance mptr2 (cadr from2))
     )
     (setq mpt2 mptr2)
    )
    ((< (distance mptl2 (cadr from2))
        (distance mptr2 (cadr from2))
     )
     (setq mpt2 mptl2)
    )
    (t
     (setq mpt2 (midpt mptl2 mptr2))
    )
     )
    )
    ((> w02 w11) ;_3.2前宽后窄
     (setq mpt1 (inters (cadr from1)
          (cadr from2)
          (car mid1)
          (cadr mid1)
          nil
         )
    mpt2 (inters (cadr from1)
          (cadr from2)
          (car mid2)
          (cadr mid2)
          nil
         )
     )
     (if (and mpt1 mpt2)
       nil
       (setq mpt1 (get-mindis-pt
      (ss-pl-inters
        from1
        mid1
      )
      (cadr from1)
    )
      mpt2 (get-mindis-pt
      (ss-pl-inters
        from2
        mid2
      )
      (cadr from2)
    )
       )
     )
    )
    ((< w02 w11) ;_3.3前窄后宽  
     (setq mpt1 (get-mindis-pt
    (ss-pl-inters
      (list (car mid1) (car mid2) 0.0)
      from1
    )
    (cadr from1)
         )
    mpt2 (get-mindis-pt
    (ss-pl-inters
      (list (car mid1) (car mid2) 0.0)
      from2
    )
    (cadr from2)
         )
     ) ;_(command "line" (list 0 0) mpt2 "")
     (if (and mpt1 mpt2)
       nil
       (setq mpt1 (get-mindis-pt
      (ss-pl-inters
        from1
        mid1
      )
      (cadr from1)
    )
      mpt2 (get-mindis-pt
      (ss-pl-inters
        from2
        mid2
      )
      (cadr from2)
    )
       )
     )
    ) ;_3.3
  ) ;_end cond
  (setq
    n1   (ss-ptc-c (car from1)
     mpt1
     (car m1)
     (> (caddr from1) 0.0)
         )
    n2   (ss-ptc-c
    (car from2)
    mpt2
    (car m2)
    (> (caddr from2) 0.0)
         )
    lst1 (cons (ch-lst n1 2 (ch-lst mpt1 1 from1))
        lst1
         )
    lst2 (cons (ch-lst n2 2 (ch-lst mpt2 1 from2))
        lst2
         )
    mid1 (ch-lst mpt1 0 mid1)
    mid2 (ch-lst mpt2 0 mid2)
    lst1 (cons mid1 lst1) ;_(check-pt (list mpt1 mpt2))
    lst2 (cons mid2 lst2)
  )
        ) ;_end 3.前弧后直
;;;
;;;_4.前段弧，后段弧                                                                            
        ((and (/= c0 0.0) (/= c1 0.0))
  (setq mid1 (car mid)
        mid2 (cadr mid)
        mid  (cddr mid)
        mid3 (car mid)
        mid4 (cadr mid)
        mid  (cddr mid)
        mid5 (car mid)
        mid6 (cadr mid)
        m1   (SS-PTC-ptcR
        (car from1)
        (cadr from1)
        (caddr from1)
      )
        m2   (SS-PTC-ptcR
        (car from2)
        (cadr from2)
        (caddr from2)
      )
        m3   (SS-PTC-ptcR
        (car mid1)
        (cadr mid1)
        (caddr mid1)
      )
        m4   (SS-PTC-ptcR
        (car mid2)
        (cadr mid2)
        (caddr mid2)
      )
  )
  (cond ((= w02 w11) ;_4.1等宽      
         (setq mpt1 (get-mindis-pt
        (ss-pl-inters from1 mid1)
        (cadr from1)
      )
        mpt2
      (get-mindis-pt
        (ss-pl-inters from2 mid2)
        (cadr from2)
      )
         ) ;_有一种可能，因为计算误差，引起交点不存在的情况需要处理
         (setq n1    (ss-ptc-c (car from1)
          mpt1
          (car m1)
          (> (caddr from1) 0.0)
       )
        from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
        n2    (ss-ptc-c
         (car from2)
         mpt2
         (car m2)
         (> (caddr from2) 0.0)
       )
        from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
        n1    (ss-ptc-c mpt1
          (cadr mid1)
          (car m3)
          (> (caddr mid1) 0.0)
       )
        mid1  (ch-lst n1 2 (ch-lst mpt1 0 mid1))
        n2    (ss-ptc-c mpt2
          (cadr mid2)
          (car m4)
          (> (caddr mid2) 0.0)
       )
        mid2  (ch-lst n2 2 (ch-lst mpt2 0 mid2))
        lst1  (cons mid1 (cons from1 lst1))
        lst2  (cons mid2 (cons from2 lst2))
         )
        )
        ((> w02 w11) ;_4.2前宽后窄      
         (setq mpt1 (get-mindis-pt
        (ss-pl-inters
          (list (cadr from1) (cadr from2) 0.0)
          mid1
        )
        (car mid1)
      )
        mpt2 (get-mindis-pt
        (ss-pl-inters
          (list (cadr from1) (cadr from2) 0.0)
          mid2
        )
        (car mid2)
      )
         )
         (if (and mpt1 mpt2)
    (progn
      (setq n1 (ss-ptc-c mpt1
           (cadr mid1)
           (car m3)
           (> (caddr mid1) 0.0)
        )
     n2 (ss-ptc-c mpt2
           (cadr mid2)
           (car m4)
           (> (caddr mid2) 0.0)
        )
      )
      (setq lst1 (cons from1 lst1)
     lst2 (cons from2 lst2)
     mid1 (ch-lst n1 2 (ch-lst mpt1 0 mid1))
     mid2 (ch-lst n2 2 (ch-lst mpt2 0 mid2))
     lst1 (cons mid1 lst1)
     lst2 (cons mid2 lst2)
      )
    )
 ;_凸度同号，可能不存在交在宽者法边     
    (setq mpt1  (get-mindis-pt
           (ss-pl-inters
      from1
      mid1
           )
           (car mid1)
         )
          mpt2  (get-mindis-pt
           (ss-pl-inters
      from2
      mid2
           )
           (car mid2)
         ) ;_(check-pt (list mpt1 mpt2))      
          n1    (ss-ptc-c (car from1)
            mpt1
            (car m1)
            (> (caddr from1) 0.0)
         )
          n2    (ss-ptc-c (car from2)
            mpt2
            (car m2)
            (> (caddr from2) 0.0)
         )
          from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
          from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
          n1    (ss-ptc-c mpt1
            (cadr mid1)
            (car m3)
            (> (caddr mid1) 0.0)
         )
          n2    (ss-ptc-c mpt2
            (cadr mid2)
            (car m4)
            (> (caddr mid2) 0.0)
         )
          mid1  (ch-lst n1 2 (ch-lst mpt1 0 mid1))
          mid2  (ch-lst n2 2 (ch-lst mpt2 0 mid2))
          lst1  (cons from1 lst1)
          lst2  (cons from2 lst2)
          lst1  (cons mid1 lst1)
          lst2  (cons mid2 lst2)
    )
         ) ;_end if 
        )
        ((< w02 w11) ;_4.3前窄后宽
         (setq mpt1 (get-mindis-pt
        (ss-pl-inters
          from1
          (list (car mid1) (car mid2) 0.0)
        )
        (cadr from1)
      )
        mpt2 (get-mindis-pt
        (ss-pl-inters
          from2
          (list (car mid1) (car mid2) 0.0)
        )
        (cadr from2)
      )
         )
         (if (and mpt1 mpt2)
    (setq n1    (ss-ptc-c (car from1)
            mpt1
            (car m1)
            (> (caddr from1) 0.0)
         )
          n2    (ss-ptc-c (car from2)
            mpt2
            (car m2)
            (> (caddr from2) 0.0)
         )
          from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
          from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
          lst1  (cons from1 lst1)
          lst2  (cons from2 lst2)
          lst1  (cons mid1 lst1)
          lst2  (cons mid2 lst2)
    )
 ;_凸度同号，可能不存在都交于宽者法边交点      
    (setq mpt1  (get-mindis-pt
           (ss-pl-inters
      from1
      mid1
           )
           p1
         )
          mpt2  (get-mindis-pt
           (ss-pl-inters
      from2
      mid2
           )
           p1
         )
          n1    (ss-ptc-c (car from1)
            mpt1
            (car m1)
            (> (caddr from1) 0.0)
         )
          n2    (ss-ptc-c (car from2)
            mpt2
            (car m2)
            (> (caddr from2) 0.0)
         )
          from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
          from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
          n1    (ss-ptc-c mpt1
            (cadr mid1)
            (car m3)
            (> (caddr mid1) 0.0)
         )
          n2    (ss-ptc-c mpt2
            (cadr mid2)
            (car m4)
            (> (caddr mid2) 0.0)
         )
          mid1  (ch-lst n1 2 (ch-lst mpt1 0 mid1))
          mid2  (ch-lst n2 2 (ch-lst mpt2 0 mid2))
          lst1  (cons from1 lst1)
          lst2  (cons from2 lst2)
          lst1  (cons mid1 lst1)
          lst2  (cons mid2 lst2)
    )
         ) ;_end if 
        )
  )
  (setq
    lst1
         (cons mid5 (cons mid3 lst1))
    lst2
         (cons mid6 (cons mid4 lst2))
  )
        ) ;_end cond 4   
      ) ;_end cond   
    ) ;_end pro
 ) ;_end if
      ) ;_end if pro
    ) ;_end if 
    (setq w02 w12
   w01 w11
   c0  c1
   b   nil
   i   (1+ i)
    )
  ) ;_end foreach
;;;双环列表创建完毕
;;;
;;;首尾连接处理
  (if (= is_close 1)
    (progn
      (setq from1 (car lst1)
     mid1  (last lst1)
     from2 (car lst2)
     mid2  (last lst2)
      )
      (setq mpt1 (get-mindis-pt (ss-pl-inters from1 mid1) (car mid1)) ;_(command "LINE" (list 0 0 0) mpt2 "")
     mpt2 (get-mindis-pt (ss-pl-inters from2 mid2) (car mid2))
      )
      (setq
 n1    (if (= (caddr from1) 0.0)
  0.0
  (ss-ptc-c
    (car from1)
    mpt1
    (car (SS-PTC-ptcR
    (car from1)
    (cadr from1)
    (caddr from1)
         )
    )
    (> (caddr from1) 0.0)
  )
       )
 n2    (if (= (caddr from2) 0.0)
  0.0
  (ss-ptc-c (car from2)
     mpt2
     (car (SS-PTC-ptcR
     (car from2)
     (cadr from2)
     (caddr from2)
          )
     )
     (> (caddr from2) 0.0)
  )
       )
 from1 (ch-lst n1 2 (ch-lst mpt1 1 from1))
 from2 (ch-lst n2 2 (ch-lst mpt2 1 from2))
 n1    (if (= (caddr mid1) 0.0)
  0.0
  (ss-ptc-c mpt1
     (cadr mid1)
     (car (SS-PTC-ptcR
     (car mid1)
     (cadr mid1)
     (caddr mid1)
          )
     )
     (> (caddr mid1) 0.0)
  )
       )
 n2    (if (= (caddr mid2) 0.0)
  0.0
  (ss-ptc-c mpt2
     (cadr mid2)
     (car (SS-PTC-ptcR
     (car mid2)
     (cadr mid2)
     (caddr mid2)
          )
     )
     (> (caddr mid2) 0.0)
  )
       )
 mid1  (ch-lst n1 2 (ch-lst mpt1 0 mid1))
 mid2  (ch-lst n2 2 (ch-lst mpt2 0 mid2))
 lst1  (ch-lst from1 0 lst1)
 lst1  (reverse (ch-lst mid1 0 (reverse lst1)))
 lst2  (ch-lst from2 0 lst2)
 lst2  (reverse (ch-lst mid2 0 (reverse lst2)))
      )
    )
  )
  ;;首尾连接处理完毕
     ;(setvar "osmode" 0) ;_测试用
  (setq lst1 (reverse lst1)) ;_(command "line" (list 0 0 0) (nth 0 (nth 2 lst2)) "")
  (if (= is_close 0)
    (progn
      (setq len (length lst1)
     i 1
     lst nil
      )
      (foreach a lst1
 (if (< i len)
   (progn
     (setq
       lst
        (append lst
         (list (cons 10 (car a)) (cons 42 (caddr a)))
        )
     )
     (if (eq (cadr a) (car (nth i lst1)))
       nil
       (setq lst
       (append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
       )
     )
   )
   (progn
     (setq
       lst
        (append lst
         (list (cons 10 (car a)) (cons 42 (caddr a)))
        )
     )
     (setq
       lst
        (append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
     )
   )
 )
 (setq i (1+ i))
      )
      (setq i 1)
      (foreach a lst2
 (if (< i len)
   (progn
     (setq lst
     (append
       lst
       (list (cons 10 (cadr a)) (cons 42 (* -1.0 (caddr a))))
     )
     )
     (if (eq (car a) (cadr (nth i lst2)))
       nil
       (setq lst
       (append lst (list (cons 10 (car a)) (cons 42 0.0)))
       )
     )
   )
   (progn
     (setq lst (append lst
         (list (cons 10 (cadr a))
        (cons 42 (* -1.0 (caddr a)))
         )
        )
     )
     (setq
       lst
        (append lst (list (cons 10 (car a)) (cons 42 0.0)))
     )
   )
 )
 (setq i (1+ i))
      )
      (setq lst (append (list (cons 0 "LWPOLYLINE")
         (cons 100 "AcDbEntity")
         (cons 100 "AcDbPolyline")
         (cons 90 (/ (length lst) 2))
         (cons 70 1)
         (cons 43 0.0)
   )
   lst
  )
      ) ;_(check-pt (ss-assoc 10 lst))
     ;(entmakex lst)
      (setq end (list lst))
    )
    (progn
      (setq len (length lst1)
     i 1
     lst nil
      )
      (foreach a lst1
 (if (< i len)
   (progn
     (setq
       lst
        (append lst
         (list (cons 10 (car a)) (cons 42 (caddr a)))
        )
     )
     (if (eq (cadr a) (cadr (nth i lst1)))
       nil
       (setq lst
       (append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
       )
     )
   )
   (progn
     (setq
       lst
        (append lst
         (list (cons 10 (car a)) (cons 42 (caddr a)))
        )
     )
     (if (eq (cadr a) (caar lst1))
       nil
       (setq
  lst
   (append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
       )
     )
   )
 )
 (setq i (1+ i))
      )
      (setq lst (append (list (cons 0 "LWPOLYLINE")
         (cons 100 "AcDbEntity")
         (cons 100 "AcDbPolyline")
         (cons 90 (/ (length lst) 2))
         (cons 70 1)
         (cons 43 0.0)
   )
   lst
  )
      )
     ;(entmakex lst)
      (setq i  1
     lst2 (reverse lst2)
     end  (cons lst end)
     lst  nil
      )
      (foreach a lst2
 (if (< i len)
   (progn
     (setq
       lst
        (append
   lst
   (list (cons 10 (car a)) (cons 42 (caddr a)))
        )
     )
     (if (eq (cadr a) (cadr (nth i lst2)))
       nil
       (setq lst
       (append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
       )
     )
   )
   (progn
     (setq
       lst
        (append lst
         (list (cons 10 (car a)) (cons 42 (caddr a)))
        )
     )
     (if (eq (cadr a) (caar lst2))
       nil
       (setq
  lst
   (append lst (list (cons 10 (cadr a)) (cons 42 0.0)))
       )
     )
   )
 )
 (setq i (1+ i))
      )
      (setq lst (append (list (cons 0 "LWPOLYLINE")
         (cons 100 "AcDbEntity")
         (cons 100 "AcDbPolyline")
         (cons 90 (/ (length lst) 2))
         (cons 70 1)
         (cons 43 0.0)
   )
   lst
  )
      )
      (setq end (reverse (cons lst end)))
     ;(entmakex lst)
    )
  ) ;_end if
  end
)

主函数源码2:

(defun SS-PL->SBound (pl / ent is_close pl_vetex
b i lst1 lst2 w02 c0 p1
p2 w11 w12 c1 b mid mid1
mid2
) ;(setq pl (car (entsel)))
(setq ent (entget pl '("*")))
(setq is_close (rem (cdr (assoc 70 ent)) 2))
(setq pl_vetex nil
b nil
)
(foreach n ent ;_(setq e (assoc 10 ent))
(if (or (= 10 (car n))
(= 40 (car n))
(= 41 (car n))
(= 42 (car n))
) ;_ 结束or
(progn
(setq b (cons (cdr n) b))
(if (= 4 (length b))
(setq pl_vetex (append pl_vetex (list (reverse b)))
b nil
)
)
)
)
)
(setq i 0
b nil
)
(foreach a pl_vetex ;(setq a (nth 1 pl_vetex))
(setq p1 (car a)
w11 (cadr a)
w12 (caddr a)
c1 (cadddr a)
b (nth (1+ i) pl_vetex)
)
;_(if (= i 1) (princ "pause"))
(if (and (null b) (= is_close 1))
(setq b (car pl_vetex))
)
(if (setq p2 (car b))
(progn
(setq mid (ss-plwk-pts p1 w11 w12 c1 p2)
lst1 nil
lst2 nil
lst3 nil
lst4 nil
)
(repeat (/ (length mid) 2)
(setq
mid1 (car mid)
mid2 (cadr mid)
mid (cddr mid)
lst1 (if (equal (car mid1) (car lst1))
(cons (cadr mid1) lst1)
(cons (cadr mid1) (cons (car mid1) lst1))
)
lst2 (if (equal (car mid2) (car lst2))
(cons (cadr mid2) lst2)
(cons (cadr mid2) (cons (car mid2) lst2))
)
lst3 (cons (caddr mid1) lst3)
lst4 (cons (* -1.0 (caddr mid2)) lst4)
)
)
(draw-pline
(append (reverse lst1) lst2)
0.0
(append (reverse lst3) (append (cons 0.0 lst4) (list 0.0)))
nil
-1
1
)
) ;_end if pro
)
(setq i (1+ i))
) ;_end foreach
;_end if
(princ)
)

(defun SS-PL->SBound (pl     /     ent    is_close  pl_vetex
        b      i     lst1   lst2   w02  c0 p1
        p2     w11    w12    c1   b  mid mid1
        mid2
       )   ;(setq pl (car (entsel)))  
  (setq ent (entget pl '("*")))
  (setq is_close (rem (cdr (assoc 70 ent)) 2))
  (setq pl_vetex nil
 b nil
  )
  (foreach n ent ;_(setq e (assoc 10 ent))
    (if (or (= 10 (car n))
     (= 40 (car n))
     (= 41 (car n))
     (= 42 (car n))
 ) ;_ 结束or
      (progn
 (setq b (cons (cdr n) b))
 (if (= 4 (length b))
   (setq pl_vetex (append pl_vetex (list (reverse b)))
  b  nil
   )
 )
      )
    )
  )
  (setq i 0
 b nil
  )
  (foreach a pl_vetex   ;(setq a (nth 1 pl_vetex))
    (setq p1  (car a)
   w11 (cadr a)
   w12 (caddr a)
   c1  (cadddr a)
   b   (nth (1+ i) pl_vetex)
    )
   ;_(if (= i 1) (princ "pause"))
    (if (and (null b) (= is_close 1))
      (setq b (car pl_vetex))
    )
    (if (setq p2 (car b))
      (progn
 (setq mid  (ss-plwk-pts p1 w11 w12 c1 p2)
       lst1 nil
       lst2 nil
       lst3 nil
       lst4 nil
 )
 (repeat (/ (length mid) 2)
   (setq
     mid1 (car mid)
     mid2 (cadr mid)
     mid  (cddr mid)
     lst1 (if (equal (car mid1) (car lst1))
     (cons (cadr mid1) lst1)
     (cons (cadr mid1) (cons (car mid1) lst1))
   )
     lst2 (if (equal (car mid2) (car lst2))
     (cons (cadr mid2) lst2)
     (cons (cadr mid2) (cons (car mid2) lst2))
   )
     lst3 (cons (caddr mid1) lst3)
     lst4 (cons (* -1.0 (caddr mid2)) lst4)
   )
 )
 (draw-pline
   (append (reverse lst1) lst2)
   0.0
   (append (reverse lst3) (append (cons 0.0 lst4) (list 0.0)))
   nil
   -1
   1
 )
      ) ;_end if pro    
    )
    (setq i (1+ i))
  ) ;_end foreach  
 ;_end if
  (princ)
)

配套函数源码3:

;;;配套函数-------------------------------------------------------------;;;
(setq _pi2 1.5707963267948966192313216916395
_2pi 6.283185307179586476925286766559
_1d 0.0174532925199433
)
;;;---------------------------------------------------------------------;;;
;;;获取单段PL线的4个角点和两边凸度
;;;直线段返回4个点((pt11 pt21 n11) (pt12 pt22 n12))
;;;高山流水2010-06-25
;;;(ss-plwk-pts p1 w11 w12 c1 p2)
;;;(setq pt1 p1 w1 w11 w2 12 n c1 pt2 p2)
(defun ss-plwk-pts (pt1 w1 w2 n pt2 / ptcR0
ptc0 R0 mpt0 ang1 ang2 ang2a ang2a/6 dw pt11
pt12 pt21 pt22 ptm1 ptm2 ptcr1 ptcr2
ptlst lst i n1 n2
)
(if (/= n 0.0)
(progn
(setq ptcR0 (SS-PTC-ptcR pt1 pt2 n)
ptc0 (car ptcr0)
R0 (cadr ptcr0)
ang1 (angle ptc0 pt1)
ang2 (angle ptc0 pt2)
ang2a (angle (list 0.0 0.0 0.0) (gsls-XY->AB pt2 ptc0 ang1))
ang2a (if (> n 0)
ang2a
(- ang2a _2pi)
)
ang2a/6 (/ ang2a 6.0)
dw (/ (- w2 w1) 6.0)
)
(setq i 0
ptlst nil)
(repeat 7
(setq pt11 (polar (polar ptc0 (+ ang1 (* i ang2a/6)) R0) (+ ang1 (* i ang2a/6) pi) (/ (+ w1 (* i dw)) 2.0))
pt12 (polar (polar ptc0 (+ ang1 (* i ang2a/6)) R0) (+ ang1 (* i ang2a/6)) (/ (+ w1 (* i dw)) 2.0))
ptlst (cons pt12 (cons pt11 ptlst))
i (1+ i)
)
)
;(check-pt ptlst)
(setq i 0
ptlst (reverse ptlst)
lst nil
)
(repeat 3
(setq pt11 (nth (* i 4) ptlst)
pt12 (nth (1+ (* i 4)) ptlst)
ptm1 (nth (+ (* i 4) 2) ptlst)
ptm2 (nth (+ (* i 4) 3) ptlst)
pt21 (nth (+ (* i 4) 4) ptlst)
pt22 (nth (+ (* i 4) 5) ptlst)
ptcr1 (SS-PT-ptcR pt11 ptm1 pt21)
ptcr2 (ss-pt-ptcr pt12 ptm2 pt22)
n1 (ss-ptc-c pt11 pt21 (car ptcr1) (> n 0))
n2 (ss-ptc-c pt12 pt22 (car ptcr2) (> n 0))
)
(if (> n 0.0)
(setq lst (cons (list pt12 pt22 n2) (cons (list pt11 pt21 n1) lst)))
(setq lst (cons (list pt11 pt21 n1) (cons (list pt12 pt22 n2) lst)))
)
(setq i (1+ i))
)
(setq lst (reverse lst))
)
(progn
(setq ang (angle pt1 pt2)
pt11 (polar pt1 (+ ang _pi2) (/ w1 2.0))
pt12 (polar pt1 (- ang _pi2) (/ w1 2.0))
pt21 (polar pt2 (+ ang _pi2) (/ w2 2.0))
pt22 (polar pt2 (- ang _pi2) (/ w2 2.0))
)
(list (list pt11 pt21 0.0) (list pt12 pt22 0.0))
)
)
)
;;;---------------------------------------------------------------------;;;
;;;已知圆弧起点、终点和凸度，求圆心和半径
;;;高山流水2010-06-25
;;;(SS-PTC-ptcR '(764814.0 -1.11779e+006 0.0) '(734523.0 -1.11239e+006) -0.722053)
(defun SS-PTC-ptcR (pt1 pt2 convexity / ang mpt a b ptc R)
(setq ang (angle pt1 pt2)
mpt (midpt pt1 pt2)
b (distance pt1 mpt)
a (* b
(/ (sin (- _pi2 (* 2.0 (atan convexity))))
(cos (- _pi2 (* 2.0 (atan convexity))))
)
)
ptc (polar mpt (+ ang _pi2) a)
R (sqrt (+ (* a a) (* b b)))
)
(list ptc R)
)
;;;---------------------------------------------------------------------;;;
;;;已知圆弧上的3点，求圆心和半径
;;;高山流水2010-06-25
(defun SS-PT-ptcR (pt1 mpt pt2 / mpt1 mpt2 mpt11 mpt22 ptc R)
(setq mpt1 (midpt pt1 mpt)
mpt2 (midpt mpt pt2)
mpt11 (polar mpt1 (+ (angle pt1 mpt) _pi2) 1000.0)
mpt22 (polar mpt2 (+ (angle mpt pt2) _pi2) 1000.0)
ptc (inters mpt1 mpt11 mpt2 mpt22 nil)
R (distance ptc pt1)
);_(check-pt (list pt1 mpt pt2))
(list ptc R)
)
;;;---------------------------------------------------------------------;;;
;;;已知圆弧的端点pt1->pt2,圆心ptc,求凸度
;;;高山流水2010-06-26
;;;
(defun ss-ptc-c (pt1 pt2 ptc is_nsz / ang1 pt2a ang2)
(setq ang1 (angle ptc pt1)
pt2a (gsls-XY->AB pt2 ptc ang1)
ang2 (angle (list 0.0 0.0 0.0) pt2a)
)
(if is_nsz
nil
(setq ang2 (- ang2 _2pi))
)
(/ (sin (/ ang2 4.0)) (cos (/ ang2 4.0)))
)
;;;---------------------------------------------------------------------;;;
;;;将点XY坐标换算为AB坐标，AB坐标的原点为PT0，转角为R0
;;;A=(X-X0)cosR0+(Y-Y0)sinR0
;;;B=(Y-Y0)cosR0-(X-X0)sinR0
(defun gsls-XY->AB (pt pt0 ANG / A B)
(setq A (+ (* (- (car pt) (car pt0)) (cos ANG))
(* (- (cadr pt) (cadr pt0)) (sin ANG))
)
B (- (* (- (cadr pt) (cadr pt0)) (cos ANG))
(* (- (car pt) (car pt0)) (sin ANG))
)
)
(list A B 0.0)
)
;;;---------------------------------------------------------------------;;;
;;;求两点中点
(defun midpt (pta ptb)
(mapcar (function (lambda (x y)
(/ (+ x y) 2.0)
)
)
pta
ptb
)
)
;;;---------------------------------------------------------------------;;;
;;;求直线、圆弧交点集,点凸版
;;;(ss-pl-inters '((713708.0 -563492.0) (717691.0 -570078.0) 0.0) '((715257.0 -566053.0) (720145.0 -553354.0) 0.280634))
(defun ss-pl-inters (mid1 mid2 / intersections)
(setq pt11 (car mid1)
pt12 (cadr mid1)
n1 (caddr mid1)
pt21 (car mid2)
pt22 (cadr mid2)
n2 (caddr mid2)
intersections nil
)
(cond ((= n1 n2 0.0) ;_直线交直线
(list (inters pt11 pt12 pt21 pt22 nil))
)
((and (= n1 0.0) (/= n2 0.0)) ;_直线交圆弧
(setq ptcr2 (SS-PTC-ptcR pt21 pt22 n2))
(L_INT_C pt11 pt12 (car ptcr2) (cadr ptcr2))
)
((and (/= n1 0.0) (= n2 0.0)) ;_圆弧交直线
(setq ptcr1 (SS-PTC-ptcR pt11 pt12 n1))
(L_INT_C pt21 pt22 (car ptcr1) (cadr ptcr1))
)
((and (/= n1 0.0) (/= n2 0.0)) ;_圆弧交圆弧
(setq ptcr1 (SS-PTC-ptcR pt11 pt12 n1)
ptcr2 (SS-PTC-ptcR pt21 pt22 n2)
)
(c_int_c (car ptcr1) (cadr ptcr1) (car ptcr2) (cadr ptcr2))
)
)
)
;;;---------------------------------------------------------------------;;;
;;;此函数2010.07.06改版,注意其他程序
(defun gsls-ang-trans (ang)
(while (> ang pi)
(setq ang (- ang pi))
)
(while (< ang 0.0)
(setq ang (+ ang pi))
)
ang
)
;;;---------------------------------------------------------------------;;;
;;;用到WK函数
;___________________直线与圆交点函数,输入值直线端点1,端点2,圆心,半径.返回值交点表
(defun L_INT_C (l_end1 l_end2 c_cen c_rad / pedal dist_cen_l int1 int2
ints)
(setq pedal (pedal_to_line c_cen l_end1 l_end2)
dist_cen_l (distance pedal c_cen))
(cond
((equal c_rad dist_cen_l min_num) (setq ints (list pedal)))
((> c_rad dist_cen_l)
(progn
(setq int1
(polar pedal
(angle l_end1 l_end2)
(sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l)))
)
)
(setq int2
(polar pedal
(+ pi (angle l_end1 l_end2))
(sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l)))
)
)
(setq ints (list int1 int2))
)
)
)
ints
)
;;;点到直线的垂足坐标
(defun pedal_to_line (pt pt1 pt2)
(inters
pt
(polar pt (+ (/ pi 2) (angle pt1 pt2)) 1000)
pt1
pt2
nil
)
)
;_精度设置_________________________________________________
(setq min_num 1e-7)
;___________________圆与圆交点函数,输入值圆心1,半径1,圆心2,半径2.返回值交点表
(defun c_int_c (c1_cen c1_rad c2_cen c2_rad / ints c1c2_dis dd ee)
(setq c1c2_dis (distance c1_cen c2_cen))
(cond
((equal c1c2_dis (+ c1_rad c2_rad) min_num)
(setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad)))
)
((equal c1c2_dis (abs (- c1_rad c2_rad)) min_num)
(if (minusp (- c1_rad c2_rad))
(setq ints (list (polar c2_cen (angle c2_cen c1_cen) c2_rad)))
(setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad)))
)
)
((and (> c1c2_dis (abs (- c1_rad c2_rad)))
(< c1c2_dis (+ c1_rad c2_rad))
)
(progn
(setq dd (/ (- (+ (* c1c2_dis c1c2_dis) (* c1_rad c1_rad))
(* c2_rad c2_rad)
)
(* 2 c1c2_dis)
)
)
(setq ee (sqrt (- (* c1_rad c1_rad) (* dd dd))))
(setq
ints (list (polar (polar c1_cen (angle c1_cen c2_cen) dd)
(+ (angle c1_cen c2_cen) (/ pi 2))
ee
)
)
)
(setq ints
(append
ints
(list (polar (polar c1_cen (angle c1_cen c2_cen) dd)
(- (angle c1_cen c2_cen) (/ pi 2))
ee
)
)
)
)
)
)
)
ints
)
;;;________________________________________________;;;
;;;---------------------------------------------------------------------;;;
;;;其他函数
;;;获取点集ptlst中与点pt距离最近的点
(defun get-mindis-pt (ptlst pt)
(car
(vl-sort ptlst
(function (lambda (e1 e2)
(< (distance e1 pt) (distance e2 pt))
)
)
)
)
)
;;;---------------------------------------------------------------------;;;
;;;参考qj_chen表项替代函数改进
;;;表项替换，支持2重表，当指定i为list如(3 1)时，替换第3个子表中的第1个元素
(defun ch-lst (new i lst / j len fst mid)
(if (/= (type i) 'list)
(cond
((minusp i)
lst
)
((> i (setq len (length lst)))
lst
)
((> i (/ len 2))
(reverse (ch-lst new (1- (- 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)
(cdr lst)
)
)
)
(progn
(setq j (cadr i)
i (car i)
)
(if j
(progn
(setq mid (nth i lst))
(setq mid (ch-lst new j mid))
(ch-lst mid i lst)
)
(ch-lst new i lst)
)
)
)
)
;;;---------------------------------------------------------------------;;;
;;;用到吴所不及函数
;;;转换选择集为表
(defun wjm_ss2lst (ss / i e lst)
(if (= (type ss) 'PICKSET)
(progn
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(if (= (type e) 'ENAME) (setq lst (cons e lst)) nil)
)
lst
)
nil
)
)

;;;配套函数-------------------------------------------------------------;;;
(setq _pi2 1.5707963267948966192313216916395
      _2pi 6.283185307179586476925286766559
      _1d 0.0174532925199433
)
;;;---------------------------------------------------------------------;;;
 ;;;获取单段PL线的4个角点和两边凸度
;;;直线段返回4个点((pt11 pt21 n11) (pt12 pt22 n12))
;;;高山流水2010-06-25
;;;(ss-plwk-pts p1 w11 w12 c1 p2)
;;;(setq pt1 p1 w1 w11 w2 12 n c1 pt2 p2)
(defun ss-plwk-pts (pt1    w1   w2  n pt2    /      ptcR0
      ptc0   R0   mpt0  ang1 ang2 ang2a  ang2a/6 dw pt11
      pt12   pt21   pt22  ptm1 ptm2   ptcr1  ptcr2 
      ptlst   lst i  n1 n2
     )
  (if (/= n 0.0)
    (progn
      (setq ptcR0 (SS-PTC-ptcR pt1 pt2 n)
     ptc0  (car ptcr0)
     R0   (cadr ptcr0)    
     ang1  (angle ptc0 pt1)
     ang2  (angle ptc0 pt2)
     ang2a (angle (list 0.0 0.0 0.0) (gsls-XY->AB pt2 ptc0 ang1))
     ang2a (if (> n 0)
      ang2a
      (- ang2a _2pi)
    )
     ang2a/6 (/ ang2a 6.0)
     dw (/ (- w2 w1) 6.0)
     )
      (setq i 0
     ptlst nil)
      (repeat 7
 (setq pt11 (polar (polar ptc0 (+ ang1 (* i ang2a/6)) R0) (+ ang1 (* i ang2a/6) pi) (/ (+ w1 (* i dw)) 2.0))
       pt12 (polar (polar ptc0 (+ ang1 (* i ang2a/6)) R0) (+ ang1 (* i ang2a/6)) (/ (+ w1 (* i dw)) 2.0))
       ptlst (cons pt12 (cons pt11 ptlst))
       i (1+ i)
       )
 )
      ;(check-pt ptlst)
      (setq i 0
     ptlst (reverse ptlst)
     lst nil
     )
      (repeat 3
 (setq pt11 (nth (* i 4) ptlst)
       pt12 (nth (1+ (* i 4)) ptlst)
       ptm1 (nth (+ (* i 4) 2) ptlst)
       ptm2 (nth (+ (* i 4) 3) ptlst)
       pt21 (nth (+ (* i 4) 4) ptlst)
       pt22 (nth (+ (* i 4) 5) ptlst)
       ptcr1 (SS-PT-ptcR pt11 ptm1 pt21)
       ptcr2 (ss-pt-ptcr pt12 ptm2 pt22)
       n1 (ss-ptc-c pt11 pt21 (car ptcr1) (> n 0))
       n2 (ss-ptc-c pt12 pt22 (car ptcr2) (> n 0))
       )
 (if (> n 0.0)
 (setq lst (cons (list pt12 pt22 n2) (cons (list pt11 pt21 n1) lst)))
  (setq lst (cons (list pt11 pt21 n1) (cons (list pt12 pt22 n2) lst))) 
      )
 (setq i (1+ i))
 )
      (setq lst (reverse lst))
    )
    (progn
      (setq ang  (angle pt1 pt2)
     pt11 (polar pt1 (+ ang _pi2) (/ w1 2.0))
     pt12 (polar pt1 (- ang _pi2) (/ w1 2.0))
     pt21 (polar pt2 (+ ang _pi2) (/ w2 2.0))
     pt22 (polar pt2 (- ang _pi2) (/ w2 2.0))
      )
      (list (list pt11 pt21 0.0) (list pt12 pt22 0.0))
    )
  )
)
;;;---------------------------------------------------------------------;;;
;;;已知圆弧起点、终点和凸度，求圆心和半径
;;;高山流水2010-06-25
;;;(SS-PTC-ptcR '(764814.0 -1.11779e+006 0.0) '(734523.0 -1.11239e+006) -0.722053)
(defun SS-PTC-ptcR (pt1 pt2 convexity / ang mpt a b ptc R)
  (setq ang (angle pt1 pt2)
 mpt (midpt pt1 pt2)
 b   (distance pt1 mpt)
 a   (* b
        (/ (sin (- _pi2 (* 2.0 (atan convexity))))
    (cos (- _pi2 (* 2.0 (atan convexity))))
        )
     )
 ptc (polar mpt (+ ang _pi2) a)
 R   (sqrt (+ (* a a) (* b b)))
  )
  (list ptc R)
)
;;;---------------------------------------------------------------------;;;
;;;已知圆弧上的3点，求圆心和半径
;;;高山流水2010-06-25
(defun SS-PT-ptcR (pt1 mpt pt2 / mpt1 mpt2 mpt11 mpt22 ptc R)
  (setq mpt1  (midpt pt1 mpt)
 mpt2  (midpt mpt pt2)
 mpt11 (polar mpt1 (+ (angle pt1 mpt) _pi2) 1000.0)
 mpt22 (polar mpt2 (+ (angle mpt pt2) _pi2) 1000.0)
 ptc   (inters mpt1 mpt11 mpt2 mpt22 nil)
 R     (distance ptc pt1)
  );_(check-pt (list pt1 mpt pt2))
  (list ptc R)
)
;;;---------------------------------------------------------------------;;;
;;;已知圆弧的端点pt1->pt2,圆心ptc,求凸度
;;;高山流水2010-06-26
;;;
(defun ss-ptc-c (pt1 pt2 ptc is_nsz / ang1 pt2a ang2)
  (setq ang1 (angle ptc pt1)
 pt2a (gsls-XY->AB pt2 ptc ang1)
 ang2 (angle (list 0.0 0.0 0.0) pt2a)
  )
  (if is_nsz
    nil
    (setq ang2 (- ang2 _2pi))
  )
  (/ (sin (/ ang2 4.0)) (cos (/ ang2 4.0)))
)
;;;---------------------------------------------------------------------;;;
;;;将点XY坐标换算为AB坐标，AB坐标的原点为PT0，转角为R0
;;;A=(X-X0)cosR0+(Y-Y0)sinR0
;;;B=(Y-Y0)cosR0-(X-X0)sinR0
(defun gsls-XY->AB (pt pt0 ANG / A B)
  (setq A (+ (* (- (car pt) (car pt0)) (cos ANG))
      (* (- (cadr pt) (cadr pt0)) (sin ANG))
   )
 B (- (* (- (cadr pt) (cadr pt0)) (cos ANG))
      (* (- (car pt) (car pt0)) (sin ANG))
   )
  )
  (list A B 0.0)
)
;;;---------------------------------------------------------------------;;;
;;;求两点中点
(defun midpt (pta ptb)
  (mapcar (function (lambda (x y)
        (/ (+ x y) 2.0)
      )
   )
   pta
   ptb
  )
)
;;;---------------------------------------------------------------------;;;
;;;求直线、圆弧交点集,点凸版
;;;(ss-pl-inters '((713708.0 -563492.0) (717691.0 -570078.0) 0.0) '((715257.0 -566053.0) (720145.0 -553354.0) 0.280634))
(defun ss-pl-inters (mid1 mid2 / intersections)
  (setq pt11 (car mid1)
 pt12 (cadr mid1)
 n1 (caddr mid1)
 pt21 (car mid2)
 pt22 (cadr mid2)
 n2 (caddr mid2)
 intersections nil
  )
  (cond ((= n1 n2 0.0) ;_直线交直线
  (list (inters pt11 pt12 pt21 pt22 nil))
 )
 ((and (= n1 0.0) (/= n2 0.0)) ;_直线交圆弧
  (setq ptcr2 (SS-PTC-ptcR pt21 pt22 n2))
  (L_INT_C pt11 pt12 (car ptcr2) (cadr ptcr2))
 )
 ((and (/= n1 0.0) (= n2 0.0)) ;_圆弧交直线
  (setq ptcr1 (SS-PTC-ptcR pt11 pt12 n1))
  (L_INT_C pt21 pt22 (car ptcr1) (cadr ptcr1))
 )
 ((and (/= n1 0.0) (/= n2 0.0)) ;_圆弧交圆弧
  (setq ptcr1 (SS-PTC-ptcR pt11 pt12 n1)
        ptcr2 (SS-PTC-ptcR pt21 pt22 n2)
  )
  (c_int_c (car ptcr1) (cadr ptcr1) (car ptcr2) (cadr ptcr2))
 )
  )
)
;;;---------------------------------------------------------------------;;;
;;;此函数2010.07.06改版,注意其他程序
(defun gsls-ang-trans (ang)
  (while (> ang pi)
    (setq ang (- ang pi))
  )
  (while (< ang 0.0)
    (setq ang (+ ang pi))
  )
  ang
)
;;;---------------------------------------------------------------------;;;
;;;用到WK函数
 ;___________________直线与圆交点函数,输入值直线端点1,端点2,圆心,半径.返回值交点表
  (defun L_INT_C (l_end1 l_end2 c_cen c_rad / pedal dist_cen_l int1 int2
    ints)
    (setq pedal (pedal_to_line c_cen l_end1 l_end2)
   dist_cen_l (distance pedal c_cen))
    (cond
      ((equal c_rad dist_cen_l min_num) (setq ints (list pedal)))
      ((> c_rad dist_cen_l)
       (progn
  (setq int1
  (polar pedal
         (angle l_end1 l_end2)
         (sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l)))
  )
  )
  (setq int2
  (polar pedal
         (+ pi (angle l_end1 l_end2))
         (sqrt (- (* c_rad c_rad) (* dist_cen_l dist_cen_l)))
  )
  )
  (setq ints (list int1 int2))
       )
      )
    )
    ints
  )
;;;点到直线的垂足坐标
(defun pedal_to_line (pt pt1 pt2)
  (inters
    pt
    (polar pt (+ (/ pi 2) (angle pt1 pt2)) 1000)
    pt1
    pt2
    nil
  )
)
;_精度设置_________________________________________________
  (setq min_num 1e-7)
 ;___________________圆与圆交点函数,输入值圆心1,半径1,圆心2,半径2.返回值交点表
  (defun c_int_c (c1_cen c1_rad c2_cen c2_rad / ints c1c2_dis dd ee)
    (setq c1c2_dis (distance c1_cen c2_cen))
    (cond
      ((equal c1c2_dis (+ c1_rad c2_rad) min_num)
       (setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad)))
      )
      ((equal c1c2_dis (abs (- c1_rad c2_rad)) min_num)
       (if (minusp (- c1_rad c2_rad))
  (setq ints (list (polar c2_cen (angle c2_cen c1_cen) c2_rad)))
  (setq ints (list (polar c1_cen (angle c1_cen c2_cen) c1_rad)))
       )
      )
      ((and (> c1c2_dis (abs (- c1_rad c2_rad)))
     (< c1c2_dis (+ c1_rad c2_rad))
       )
       (progn
  (setq dd (/ (- (+ (* c1c2_dis c1c2_dis) (* c1_rad c1_rad))
   (* c2_rad c2_rad)
       )
       (* 2 c1c2_dis)
    )
  )
  (setq ee (sqrt (- (* c1_rad c1_rad) (* dd dd))))
  (setq
    ints (list (polar (polar c1_cen (angle c1_cen c2_cen) dd)
        (+ (angle c1_cen c2_cen) (/ pi 2))
        ee
        )
  )
  )
  (setq ints
  (append
    ints
    (list (polar (polar c1_cen (angle c1_cen c2_cen) dd)
          (- (angle c1_cen c2_cen) (/ pi 2))
          ee
   )
    )
  )
  )
       )
      )
    )
    ints
  )
;;;________________________________________________;;;
;;;---------------------------------------------------------------------;;;
;;;其他函数
;;;获取点集ptlst中与点pt距离最近的点
(defun get-mindis-pt (ptlst pt)
  (car
    (vl-sort ptlst
      (function (lambda (e1 e2)
    (< (distance e1 pt) (distance e2 pt))
         )
      )
    )
  )
)
;;;---------------------------------------------------------------------;;;
;;;参考qj_chen表项替代函数改进
;;;表项替换，支持2重表，当指定i为list如(3 1)时，替换第3个子表中的第1个元素
(defun ch-lst (new i lst / j len fst mid)
  (if (/= (type i) 'list)
    (cond
      ((minusp i)
       lst
      )
      ((> i (setq len (length lst)))
       lst
      )
      ((> i (/ len 2))
       (reverse (ch-lst new (1- (- 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)
  (cdr lst)
       )
      )
    )
    (progn
      (setq j (cadr i)
     i (car i)
      )
      (if j
 (progn
   (setq mid (nth i lst))
   (setq mid (ch-lst new j mid))
   (ch-lst mid i lst)
 )
 (ch-lst new i lst)
      )
    )
  )
)
;;;---------------------------------------------------------------------;;;
;;;用到 吴所不及 函数
;;;转换选择集为表
(defun wjm_ss2lst (ss / i e lst)
  (if (= (type ss) 'PICKSET)
    (progn
      (setq i -1)
      (while (setq e (ssname ss (setq i (1+ i))))
 (if (= (type e) 'ENAME) (setq lst (cons e lst)) nil)
      )
      lst
    )
    nil
  )
)

如有问题请采用下列代码将问题图元表贴出

;;;实体与字符串互换
(defun obj->str (ent / relst mid ent)
(setq relst (list -1 330 330 5 100 100 102 102 410))
(setq mid (print ent))
(foreach num relst
(progn
(setq mid (vl-remove (assoc num mid) mid))
)
)
(vl-prin1-to-string mid)
)
(defun c:tt ()
(obj->str (entget (car (entsel)) '("*")))
(princ)
)

chlh_jd · 发表于 2010-8-9 16:13:00

danxingpen · 发表于 2010-8-10 10:39:00

习惯性的收藏一下，，，，，，，

13579 · 发表于 2010-10-15 17:10:00

xhq1954425 · 发表于 2010-10-15 17:40:00

支持一下！

Gu_xl · 发表于 2010-10-15 19:01:00

很不错！支持楼主的无私！ppl1命令缺少DRAW-PLINE函数，请楼主补一下！

xyp1964 · 发表于 2010-10-16 16:43:00

“高山”应该继续研究下去……

chlh_jd · 发表于 2010-10-24 00:07:00

应6楼要求，把缺漏函数补上

;;--------------------------------------------------------------------------------------;;;
;;;draw-pline ;;;
;;;--------------------------------------------------------------------------------------;;;
;;;
;;;function: to make a polyline by code and return ename
;;;
;;;Variants:
;;;pl_list: the points list offered by order
;;;width : 0.0 or num, or a list like ((0.0 0.0) (0.0 20) (20 0.0)...),if nil it will getvar "plinewid" ,
;;; if it's length noteq d90 then wid41 and wid42 equal to 0.0 .
;;;d42_lst: 0.0 or num, or nil, if nil or it's length noteq d90 then d42 equal to 0.0 .
;;;
;;;lay_pl: layername, if nil it will getvar "CLAYER"
;;;
;;;color : color number, if it's -1 then getvar "COLOR" ellse set it by the given color number
;;;
;;;Prompt:
;;;If width list or d42_lst list is Exist , it's order must be same to the pl_list,
;;; otherwise it will take out a wrong polyline .
;;;
;;;Written By WJM and GSLS(SS),2010.06.30
;;;
(defun draw-pline
(pl_list width d42_lst lay_pl color d70
/ d90 i wid d42 wid40
wid41 en000 pb
) ;_加入宽度列表和凸度列表
(setq d90 (length pl_list)
pb '()
i 0
)
(cond ((and (listp width)
(listp d42_lst)
(= (length width) (length d42_lst) d90)
)
(foreach pt pl_list
(setq wid (nth i width)
d42 (nth i d42_lst)
wid40 (car wid)
wid41 (cadr wid)
pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 d42)
)
)
i (1+ i)
)
)
)
((and (or (numberp width) (null width))
(listp d42_lst)
(= (length d42_lst) d90)
)
(if (null width)
(setq wid40 (getvar "plinewid")
wid41 (getvar "plinewid")
)
(setq wid40 width
wid41 width
)
)
(foreach pt pl_list
(setq d42 (nth i d42_lst)
pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 d42)
)
)
i (1+ i)
)
)
)
((and (listp width)
(= (length width) d90)
(or (null d42_lst) (numberp d42_lst))
)
(if (null d42_lst)
(setq d42 0.0)
(setq d42 d42_lst)
)
(foreach pt pl_list
(setq wid (nth i width)
wid40 (car wid)
wid41 (cadr wid)
pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 d42)
)
)
i (1+ i)
)
)
)
(t
(if (numberp width)
(setq wid40 width
wid41 width
)
(setq wid40 0.0
wid41 0.0
)
)
(foreach pt pl_list
(setq pb (append pb
(list (cons 10 pt)
(cons 40 wid40)
(cons 41 wid41)
(cons 42 0.0)
)
)
)
)
)
)
(setq en000 (append (list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 8
(if (and lay_pl (/= lay_pl ""))
lay_pl
(getvar "CLAYER")
)
) ;_这里稍微改动了下
(cons 100 "AcDbPolyline")
(cons 90 d90)
(cons 70 d70)
)
pb
)
)
(if (and color (/= -1 color))
(setq en000 (append en000 (list (cons 62 color))))
)
(if (= nil (entmake en000))
(princ "\n制造 LWPL 制造失败.")
)
(entlast)
)

;;--------------------------------------------------------------------------------------;;;
;;;draw-pline                                                                                                         ;;;
;;;--------------------------------------------------------------------------------------;;;
;;;
;;;function: to make a polyline by code and return ename
;;;
;;;Variants:
;;;pl_list: the points list offered by order 
;;;width : 0.0 or num, or a list like ((0.0 0.0) (0.0 20) (20 0.0)...),if nil it will getvar "plinewid" ,
;;;        if it's length noteq d90 then wid41 and wid42 equal to 0.0 .    
;;;d42_lst: 0.0 or num, or nil, if nil or it's length noteq d90 then d42 equal to 0.0 .
;;;
;;;lay_pl: layername, if nil it will getvar "CLAYER"
;;;
;;;color : color number, if it's -1 then getvar "COLOR" ellse set it by the given color number
;;;
;;;Prompt:
;;;If width list or d42_lst list is Exist , it's order must be same to the pl_list,
;;;   otherwise it will take out a wrong polyline .
;;;
;;;Written By WJM and GSLS(SS),2010.06.30
;;;
(defun draw-pline
    (pl_list width   d42_lst lay_pl  color   d70
     /    d90    i    wid    d42    wid40
     wid41   en000   pb
    ) ;_加入宽度列表和凸度列表
  (setq d90 (length pl_list)
 pb  '()
 i   0
  )
  (cond ((and (listp width)
       (listp d42_lst)
       (= (length width) (length d42_lst) d90)
  )
  (foreach pt pl_list
    (setq wid   (nth i width)
   d42   (nth i d42_lst)
   wid40 (car wid)
   wid41 (cadr wid)
   pb    (append pb
          (list (cons 10 pt)
         (cons 40 wid40)
         (cons 41 wid41)
         (cons 42 d42)
          )
         )
   i     (1+ i)
    )
  )
 )
 ((and (or (numberp width) (null width))
       (listp d42_lst)
       (= (length d42_lst) d90)
  )
  (if (null width)
    (setq wid40 (getvar "plinewid")
   wid41 (getvar "plinewid")
    )
    (setq wid40 width
   wid41 width
    )
  )
  (foreach pt pl_list
    (setq d42 (nth i d42_lst)
   pb  (append pb
        (list (cons 10 pt)
       (cons 40 wid40)
       (cons 41 wid41)
       (cons 42 d42)
        )
       )
   i   (1+ i)
    )
  )
 )
 ((and (listp width)
       (= (length width) d90)
       (or (null d42_lst) (numberp d42_lst))
  )
  (if (null d42_lst)
    (setq d42 0.0)
    (setq d42 d42_lst)
  )
  (foreach pt pl_list
    (setq wid   (nth i width)
   wid40 (car wid)
   wid41 (cadr wid)
   pb    (append pb
          (list (cons 10 pt)
         (cons 40 wid40)
         (cons 41 wid41)
         (cons 42 d42)
          )
         )
   i     (1+ i)
    )
  )
 )
 (t
  (if (numberp width)
    (setq wid40 width
   wid41 width
    )
    (setq wid40 0.0
   wid41 0.0
    )
  )
  (foreach pt pl_list
    (setq pb (append pb
       (list (cons 10 pt)
      (cons 40 wid40)
      (cons 41 wid41)
      (cons 42 0.0)
       )
      )
    )
  )
 )
  )
  (setq en000 (append (list
   (cons 0 "LWPOLYLINE")
   (cons 100 "AcDbEntity")
   (cons 8
         (if (and lay_pl (/= lay_pl ""))
    lay_pl
    (getvar "CLAYER")
         )
   ) ;_这里稍微改动了下
   (cons 100 "AcDbPolyline")
   (cons 90 d90)
   (cons 70 d70)
        )
        pb
       )
  )
  (if (and color (/= -1 color))
    (setq en000 (append en000 (list (cons 62 color))))
  )
  (if (= nil (entmake en000))
    (princ "\n制造 LWPL 制造失败.")
  )
  (entlast)
)

chlh_jd · 发表于 2010-10-24 00:09:00

谢谢院长的鼓励，最近比较忙，得空了，结合ACAD2011看看，有没有办法简化些

Student · 发表于 2010-10-24 09:00:00

有意思，可能也很有意义。

支持

账号		自动登录	找回密码
密码			注册

[分享]宽PL线转线框，PL线剪影

评分

本帖被以下淘专辑推荐:

本帖子中包含更多资源