为Pol创建3条中心曲线
我正在尝试创建一个LISP，该LISP允许我在知道偏移距离的基础上轻松为多段线创建3条中心曲线（例如，一条带100'-55'-200'w/2'和8'偏移的3中心曲线）。我的问题是，我不知道如何通过LISP计算不同圆弧的切线值。附件是一个。dwg显示了我所说的内容。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 ;;
;;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
)
谢谢Grr！我没有想过创建一个单独的函数，这比反复使用progn要干净得多。 顺便说一句，您使用的（selectif）函数有问题，因为我无法选择LWPOLYLINE（并且假设因为errno变量没有重置为0）。
无论如何，请使用LM:Selectif并保留标题，这样您就不会违反LM的使用条款。
此外，您可能会发现比格尔的示例对于从曲线中查找切线很有用，因为这是您任务的一部分。
很抱歉，我还不习惯数学Lisp程序，所以我不知道我能帮你进一步吗 这看起来是一个有趣的几何挑战！
我已经有一段时间没有推我的几何了，因此我尝试了一个解决方案（非常有限的测试！）：
(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)
这一争吵让我感到沮丧：
(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: "
)
)
到底发生了什么，是用嵌套列表（（））追加的吗？
虽然我试过了，但仍然不知道这个例程做了什么，也许一些动画会很好。
我认为CADtutor应该包括一个“添加到收藏夹”按钮，用于查看很棒的帖子。
哎呀！固定的
谢谢
这可能有助于了解：
sg1=（）
sg2=（）
（（））=（无） 李，非常感谢！我刚刚开始测试代码，还没有发现任何大的bug！随着我深入研究代码，我对您的提示方法很好奇。与使用我在原始代码中显示的方式相比，使用vl方式有明显的优势吗？ 我已经开始对代码进行更多的测试，我发现一些奇怪的行为，至少有点随机。有时，当我选择多段线时，曲线最终不会相切，几乎会“翻转”。但是代码没有出错，所以我不知道是什么导致了问题。我附上了一个。dwg来展示我在说什么。
3CT测试。图纸
没有优势，这是同一件事，用不同的方式写。
目标是：摆脱束缚，以同样的方式为他人编写代码，但每次都做不到。
当然，他使用getdist而不是getreal，我认为这是因为用户需要获得“视觉比例”。
但在我看来，如果不是本地化5个变量，而是本地化1个assoc列表，其中包含5个关联，那么这种方法会更有用（至少我有这个想法）。
编辑：
这样地：
(not (setq int (apply 'inters (append sg1 sg2 '(())))))
嗯，我希望至少李能明白这个想法。
页:
[1]
2