[编程交流] 在p上创建直线

;;-------------------=={ List Difference }==------------------;;
;;                                                            ;;
;;  Returns items appearing exclusively in one list but not   ;;
;;  another, i.e. the relative complement: l1 \ l2            ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  l1,l2 - lists for which to return the difference          ;;
;;------------------------------------------------------------;;
;;  Returns:  List of items appearing exclusively in list l1  ;;
;;------------------------------------------------------------;;
(defun LM:ListDifference ( l1 l2 )
 (vl-remove-if '(lambda ( x ) (member x l2)) l1)
)
(defun prelst ( lst el / f )
  (vl-remove-if '(lambda ( a ) (or f (setq f (equal a el 1e-))) lst)
)
(defun suflst ( lst el )
 (cdr (vl-member-if '(lambda ( a ) (equal a el 1e-) lst))
)
(defun c:plbestfit ( / osm q ss pl vert pt ptlst anglst danglst uanglst nths ptlstn p1 p2 p3 p4 p linplst sss )
 (setq osm (getvar 'osmode))
 (setvar 'osmode 0)
 (prompt "\nPick 2d polyline")
 (setq q T)
 (while q 
   (setq ss (ssget "_+.:E:S:L" '((0 . "*POLYLINE"))))
   (if ss 
     (if (eq (cdr (assoc 100 (reverse (entget (ssname ss 0))))) "AcDb3dPolyline") (setq q T) (setq q nil))
     (setq q nil)
   )
 )
 (if (eq (cdr (assoc 0 (entget (setq pl (ssname ss 0))))) "POLYLINE")
   (progn
     (setq vert (entnext pl))
     (setq pt (cdr (assoc 10 (entget vert))))
     (setq ptlst (cons pt ptlst))
     (while (eq (cdr (assoc 0 (entget (setq vert (entnext vert))))) "VERTEX")
       (setq pt (cdr (assoc 10 (entget vert))))
       (setq ptlst (cons pt ptlst))
     )
     (setq ptlst (reverse ptlst))
   )
 )
 (if (eq (cdr (assoc 0 (entget (setq pl (ssname ss 0))))) "LWPOLYLINE")
   (progn
     (command "_.convertpoly" "H" pl "")
     (setq vert (entnext pl))
     (setq pt (cdr (assoc 10 (entget vert))))
     (setq ptlst (cons pt ptlst))
     (while (eq (cdr (assoc 0 (entget (setq vert (entnext vert))))) "VERTEX")
       (setq pt (cdr (assoc 10 (entget vert))))
       (setq ptlst (cons pt ptlst))
     )
     (setq ptlst (reverse ptlst))
     (command "_.convertpoly" "L" pl "")
   )
 )
 (setq ptlst (acet-list-remove-duplicates ptlst 1e-2))
 
 (setq anglst (mapcar '(lambda (a b) (angle a b)) ptlst (cdr ptlst)))
 (foreach ang anglst
   (cond ((<= (* 1.5 pi) ang (* 2.0 pi)) (setq danglst (cons ang danglst)))
         ((<= 0.0 ang (* 0.5 pi)) (setq uanglst (cons ang uanglst)))
   )
 )
 (setq danglst (reverse danglst) uanglst (reverse uanglst))
 
 (defun nthsegang ( anglst danglst uanglst / seglst1 seg1ang s1 seglst2 seg2ang s2 )
   (if (equal (car danglst) (car anglst) 1e- (setq seglst1 (prelst anglst (car uanglst))))
   (if (equal (car uanglst) (car anglst) 1e- (setq seglst2 (prelst anglst (car danglst))))
   (setq s1 (length seglst1) s2 (length seglst2))
   (setq sss (+ (if (null sss) 0 sss) s1 s2))
   (if seglst1 (setq seg1ang (car (vl-sort seglst1 '<=))))
   (if seglst2 (setq seg2ang (car (vl-sort seglst2 '>=))))
   (if seglst1 (setq danglst (LM:ListDifference danglst seglst1) anglst (LM:ListDifference anglst seglst1)))
   (if seglst2 (setq uanglst (LM:ListDifference uanglst seglst2) anglst (LM:ListDifference anglst seglst2)))
   (if seglst1 (if (null nths) (setq nths (cons (+ (length (prelst seglst1 seg1ang)) 1) nths)) (setq nths (cons (+ sss (- s1) (- s2) (length (prelst seglst1 seg1ang)) 1) nths))))
   (if seglst2 (if (null nths) (setq nths (cons (+ (length (prelst seglst2 seg2ang)) 1) nths)) (setq nths (cons (+ sss (- s1) (- s2) (length (prelst seglst2 seg2ang)) 1) nths))))
   (if anglst (nthsegang anglst danglst uanglst))
   nths
 )
 
 (setq nths (reverse (nthsegang anglst danglst uanglst)))
 
 (foreach n nths
   (setq ptlstn (cons (nth (- n 1) ptlst) ptlstn) ptlstn (cons (nth n ptlst) ptlstn))
 )
 
 (setq ptlstn (reverse ptlstn))
 
 (while (> (length ptlstn) 2)
   (setq p1 (car ptlstn) p2 (cadr ptlstn) p3 (caddr ptlstn) p4 (cadddr ptlstn))
   (setq p (inters p1 p2 p3 p4 nil))
   (setq linplst (cons p linplst))
   (setq ptlstn (cddr ptlstn))
 )
 
 (setq linplst (reverse linplst))
 
 (while (> (length linplst) 1)
   (setq p1 (car linplst) p2 (cadr linplst))
   (entmake (list '(0 . "LINE") '(62 . 3) (cons 10 p1) (cons 11 p2)))
   (setq linplst (cdr linplst))
 )
     
 (setvar 'osmode osm)
 (princ)
)