[编程交流] 为Pol创建3条中心曲线

(defun c:3centercurve (/ *error* prd ent1 ent2 rad1 rad2 rad3 off1 off2)
 (defun *error* (msg)
   (if (not
         (member msg '("Function cancelled" "quit / exit abort"))
       )
     (princ (strcat "\nError: " msg))
   )
   (princ)
 )
 (setq prd
        '(lambda (x)
           (wcmatch
             (cdr (assoc 0 (entget x)))
             "LWPOLYLINE"
           )
         )
 )
 (if (and (setq ent1 (selectif "\nSelect approach polyline: " prd))
          (setq ent2 (selectif "\nSelect the intersecting pline: " prd))
          (progn
            (initget (+ 1 2 4))
            (setq rad1 (getreal "\nSpecify the approach radius: "))
          )
          (progn
            (initget (+ 1 2 4))
            (setq rad2 (getreal "\nSpecify the center radius: "))
          )
          (progn
            (initget (+ 1 2 4))
            (setq rad3 (getreal "\nSpecify the ending radius: "))
          )
          (progn
            (initget (+ 1 2 4))
            (setq off1 (getreal "\nSpecify the approach offset: "))
          )
          (progn
            (initget (+ 1 2 4))
            (setq off2 (getreal "\nSpecify the tie-in offset: "))
          )
     )
   (progn
;;;This is where I am getting stuck
   )
 )
 (princ)
)
;;;Select if written by Lee Mac
(defun selectif (msg prd / ent)
 (while
   (progn (setq ent (car (entsel msg)))
          (cond
            ((= 7 (getvar 'errno))
             (princ "\nMissed, try again.")
            )
            ((not ent) nil)
            ((not (apply prd (list ent)))
             (princ "\nInvalid object selected.")
            )
          )
   )
 )
 ent
)

(defun c:test ( / *error* _GRP selfoo ent1 ent2 rad1 rad2 rad3 off1 off2 )
 (defun *error* (msg)
   (and msg
                (not (member msg '("Function cancelled" "quit / exit abort")))
                (princ (strcat "\nError: " msg))
        )
   (princ)
)
(defun _GRP ( msg / rtn ) ; "Get Real Positive"
        (and (not (initget (+ 1 2 4))) (setq rtn (getreal (strcat "\n" msg))) )
        rtn
)
 (setq selfoo (lambda ( x ) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))))
 (if 
        (and 
                (setq ent1 (car (LM:SelectIf "\nSelect approach polyline: " selfoo entsel nil)))
                (setq ent2 (car (LM:SelectIf "\nSelect the intersecting pline: " selfoo entsel nil)))
                (setq rad1 (_GRP "Specify the approach radius: "))
                (setq rad2 (_GRP "Specify the center radius: "))
                (setq rad3 (_GRP "Specify the ending radius: "))
                (setq off1 (_GRP "Specify the approach offset: "))
                (setq off2 (_GRP "Specify the tie-in offset: "))
        ); and
        (progn
                ;;;This is where I am getting stuck
        )
)
(princ)
)
;;---------------------=={ Select if }==----------------------;;
;;                                                            ;;
;;  Provides continuous selection prompts until either a      ;;
;;  predicate function is validated or a keyword is supplied. ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  msg  - prompt string                                      ;;
;;  pred - optional predicate function [selection list arg]   ;;
;;  func - selection function to invoke                       ;;
;;  keyw - optional initget argument list                     ;;
;;------------------------------------------------------------;;
;;  Returns:  Entity selection list, keyword, or nil          ;;
;;------------------------------------------------------------;;
(defun LM:SelectIf ( msg pred func keyw / sel ) (setq pred (eval pred))  
(while
        (progn (setvar 'ERRNO 0) (if keyw (apply 'initget keyw)) (setq sel (func msg))
                (cond
                        ( (= 7 (getvar 'ERRNO))
                                (princ "\nMissed, Try again.")
                        )
                        ( (eq 'STR (type sel))
                                nil
                        )
                        ( (vl-consp sel)
                                (if (and pred (not (pred sel)))
                                        (princ "\nInvalid Object Selected.")
                                )
                        )
                )
        )
)
sel
)

(defun c:3cc ( / acn aof ard cen crd ecn eof erd int per sg1 sg2 vc1 vc2 )
   (while
       (and
           (setq sg1 (getsegment "\nSelect approach line <exit>: "))
           (setq sg2 (getsegment "\nSelect intersecting line <exit>: "))
           (not (setq int (apply 'inters (append sg1 sg2 '(())))))
       )
       (princ "\nLines do not intersect.")
   )
   (cond
       (   (not
               (and sg1 sg2
                   (vl-every '(lambda ( sym msg ) (initget 6) (set sym (getdist msg)))
                      '(ard crd erd aof eof)
                      '(   "\nSpecify approach radius: "
                           "\nSpecify center radius: "
                           "\nSpecify end radius: "
                           "\nSpecify approach offset: "
                           "\nSpecify tie-in offset: "
                       )
                   )
               )
           )
       )
       (   (<= ard crd)
           (princ "\nApproach radius must be greater than center radius.")
       )
       (   (<= erd crd)
           (princ "\nEnd radius must be greater than center radius.")
       )
       (   t
           (if (< (distance int (car sg1)) (distance int (cadr sg1)))
               (setq sg1 (reverse sg1))
           )
           (if (< (distance int (cadr sg2)) (distance int (car sg2)))
               (setq sg2 (reverse sg2))
           )
           (setq per'((x) (vx1 (list (- (cadr x)) (car x))))
                 vc1 (per (apply 'mapcar (cons '- sg1)))
                 vc2 (per (apply 'mapcar (cons '- sg2)))
                 cen
               (apply 'inters
                   (append
                       (apply 'append
                           (mapcar
                              '(lambda ( x v ) (mapcar '(lambda ( y ) (mapcar '+ y v)) x))
                               (list sg1 sg2)
                               (mapcar 'vxs (list vc1 vc2) (list (+ crd aof) (+ crd eof)))
                           )
                       )
                      '( ( ) )
                   )
               )
           )
           (setq acn
               (last
                   (apply 'LM:inters-line-circle
                       (append
                           (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc1 ard))) sg1)
                           (list cen (- ard crd))
                       )
                   )
               )
           )
           (setq ecn
               (car
                   (apply 'LM:inters-line-circle
                       (append
                           (mapcar '(lambda ( x ) (mapcar '+ x (vxs vc2 erd))) sg2)
                           (list cen (- erd crd))
                       )
                   )
               )
           )
           (arc acn ard (angle acn cen) (angle '(0 0) (mapcar '- vc1)))
           (arc ecn erd (angle '(0 0) (mapcar '- vc2)) (angle ecn cen))
           (arc cen crd (angle ecn cen) (angle acn cen))
       )
   )
   (princ)
)
(defun arc ( cen rad sta ena )
   (entmake
       (list
          '(000 . "ARC")
           (cons 010 cen)
           (cons 040 rad)
           (cons 050 sta)
           (cons 051 ena)
       )
   )
)
(defun getsegment ( msg / ent enx par rtn sel typ )
   (while
       (progn (setvar 'errno 0) (setq sel (entsel msg))
           (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (null sel) nil)
               (   (= "LINE"
                       (setq ent (car sel)
                             enx (entget ent)
                             typ (cdr (assoc 0 enx))
                       )
                   )
                   (setq rtn
                       (list
                           (trans (cdr (assoc 10 enx)) 0 1)
                           (trans (cdr (assoc 11 enx)) 0 1)
                       )
                   )
                   nil
               )
               (   (= "LWPOLYLINE" typ)
                   (setq par (vlax-curve-getparamatpoint ent (vlax-curve-getclosestpointto ent (trans (cadr sel) 1 0)))
                         rtn
                       (list
                           (trans (vlax-curve-getpointatparam ent     (fix par))  0 1)
                           (trans (vlax-curve-getpointatparam ent (1+ (fix par))) 0 1)
                       )
                   )
                   nil
               )
               (   (princ "\nPlease select a line or 2D polyline."))
           )
       )
   )
   rtn
)
;; Line-Circle Intersection (vector version)  -  Lee Mac
;; Returns the point(s) of intersection between an infinite line defined by
;; points p,q and circle with centre c and radius r
(defun LM:inters-line-circle ( p q c r / v s )
   (setq v (mapcar '- q p)
         s (mapcar '- p c)
   )
   (mapcar '(lambda ( s ) (mapcar '+ p (vxs v s)))
       (quad (vxv v v) (* 2 (vxv v s)) (- (vxv s s) (* r r)))
   )
)
;; Quadratic Solution  -  Lee Mac
;; Args: a,b,c - coefficients of ax^2 + bx + c = 0
(defun quad ( a b c / d r )
   (cond
       (   (equal 0.0 (setq d (- (* b b) (* 4.0 a c))) 1e-8)
           (list (/ b (* -2.0 a)))
       )
       (   (< 0 d)
           (setq r (sqrt d))
           (list (/ (- r b) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
       )
   )
)
;; Vector Dot Product  -  Lee Mac
;; Args: u,v - vectors in R^n
(defun vxv ( u v )
   (apply '+ (mapcar '* u v))
)
;; Vector x Scalar  -  Lee Mac
;; Args: v - vector in R^n, s - real scalar
(defun vxs ( v s )
   (mapcar '(lambda ( n ) (* n s)) v)
)
;; Unit Vector  -  Lee Mac
;; Args: v - vector in R^2 or R^3
(defun vx1 ( v )
   (   (lambda ( n ) (if (equal 0.0 n 1e-10) nil (mapcar '/ v (list n n n))))
       (distance '(0.0 0.0 0.0) v)
   )
)
(vl-load-com) (princ)

([color=BLUE]vl-every[/color] '([color=BLUE]lambda[/color] ( sym msg ) ([color=BLUE]initget[/color] 6) ([color=BLUE]set[/color] sym ([color=BLUE]getdist[/color] msg)))
'(ard crd erd aof eof)
'(   [color=MAROON]"\nSpecify approach radius: "[/color]
        [color=MAROON]"\nSpecify center radius: "[/color]
        [color=MAROON]"\nSpecify end radius: "[/color]
        [color=MAROON]"\nSpecify approach offset: "[/color]
        [color=MAROON]"\nSpecify tie-in offset: "[/color]
)
)

([color=BLUE]not[/color] ([color=BLUE]setq[/color] int ([color=BLUE]apply[/color] '[color=BLUE]inters[/color] ([color=BLUE]append[/color] sg1 sg2 '(())))))