自动将矩形转换为已知度数的凹弧
Automatically convert rectangle into concave arcs with a known degree
我想自动将用户绘制的矩形的所有边都转换成凹弧（周围大约 10 度）。
我发现这个由 Marko Ribar 编写的精彩例程（抱歉，如果这不是正确的信用）完全符合我的要求，除了用户必须使用鼠标手动定义弧的方向和度数。
推动鼠标正 Y 方向 = 凸。拉鼠标负 Y 方向 = 凹面（这是我想要的）。
有谁知道如何添加代码以在选择矩形后自动向负 Y 方向拉约 10 度？有没有更简单的方法来完成这个任务，在画矩形时只做 10 度的弧而不是直线？
;Code to convert rectangle lines into arcs:
(defun c:lwstraight2arced ( / nthmassocsubst lw enx vs gr enxb p b i pt1 pt2 pt3 pt4 myrec )
;My added code to draw a rectangle by the user picking two opposite corners-----------------
(setq pt1 (getpoint "\nEnter first corner: "))
(setq pt3 (getcorner pt1 "\nEnter cross corner: "))
(setq pt2 (list (car pt1) (cadr pt3)))
(setq pt4 (list (car pt3) (cadr pt1)))
(setq myrec (command "rectangle" pt1 pt3 ""))
;end of my added code------------------------
(defun nthmassocsubst ( n key value lst / k slst p j plst m tst pslst )
(setq k (length (setq slst (member (assoc key lst) lst))))
(setq p (- (length lst) k))
(setq j -1)
(repeat p
(setq plst (cons (nth (setq j (1+ j)) lst) plst))
)
(setq plst (reverse plst))
(setq j -1)
(setq m -1)
(repeat k
(setq j (1+ j))
(if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
(setq m (1+ m))
)
(if (and (not tst) (= n m))
(setq pslst (cons (cons key value) pslst) tst t)
(setq pslst (cons (nth j slst) pslst))
)
)
(setq pslst (reverse pslst))
(append plst pslst)
)
;
; ----removed original code that has user select a line or rectangle manually-----
; (setq lw (car (entsel "\nPick LWPOLYLINE straight polygon...")))
;-----end of original code-----
;-------My new code to have a previously drawn rectangle above automatically selected-----------------------------------
(setq lw (entlast))
;-----End of my new code------
(setq enx (entget lw))
(setq vs (getvar 'viewsize))
(while (= 5 (car (setq gr (grread t))))
(setq enxb (acet-list-m-assoc 42 enx))
(setq p (cadr gr))
(setq b (/ (cadr p) vs))
(setq i -1)
(foreach dxf42 enxb
(setq enx (nthmassocsubst (setq i (1+ i)) 42 b enx))
)
(entupd (cdr (assoc -1 (entmod enx))))
)
(princ)
)
这是我希望在用户绘制矩形后实现的。没有用户输入的略微凹陷的矩形。
我已将以下步骤添加到例程中：
-Get area of rectangle by multiplying length by width.
-Draw circles and rectangles with a specific size at each corner based on square footage of rectangle in inches.
这是添加了上述内容的工作代码：
(defun c:concavearc ( / b p q s z myrecarea convertrecarea pt1 pt2 pt3 pt4 circleset24 circleset36 circleset48)
; Create concave arcs from a rectangle
(setq s 20.0) ;; Arc sagitta
(if (and (setq p (getpoint "\nSpecify first corner: "))
(setq q ((if (zerop (getvar 'worlducs)) getpoint getcorner) p "\nSpecify opposite corner: "))
(mapcar 'set '(p q) (mapcar '(lambda ( x ) (mapcar x p q)) '(min max)))
(setq z (trans '(0 0 1) 1 0 t)
b (mapcar '(lambda ( a b c ) (/ s (- a b) -0.5)) q p '(0 0))
)
)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans p 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car q) (cadr p)) 1 z))
(cons 042 (cadr b))
(cons 010 (trans q 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car p) (cadr q)) 1 z))
(cons 042 (cadr b))
(cons 210 z)
)
)
)
;Add width of 2" and dashed line to arc polyline -----------------------------------------
(setvar "cmdecho" 0); disable command echo
(setq Plnwdth (ssget "L"));get last entity
(command "pedit" Plnwdth "W" 2 "");set last entity width to 2
(if (null (tblsearch "ltype" "dashed"))
(command ".linetype" "load" "dashed" "acad.lin" "")
)
(command "change" Plnwdth "" "p" "LType" "Dashed" "" "ltScale" "30" "");lynetype
(setvar "cmdecho" 1); restore command echo
;end add width of 2 to arc polyline-----------------------------------------
;End concave arcs-----------------------------------------
;Setting corners of rectangle to variables --------------------------------------------------------------
; Get the four points of rectangle drawn by user above
(setq pt1 p)
(setq pt3 q)
(setq pt2 (list (car pt1) (cadr pt3)))
(setq pt4 (list (car pt3) (cadr pt1)))
(setq mylength (distance pt1 pt2)); length
(setq mywidth (distance pt1 pt4)); width
(setq myrecarea (* mylength mywidth)); Get area of rectangle (length x width)
(setvar "unitmode" 1);units to be displayed as entered
(setq convertrecarea (rtos myrecarea 4 2)); converts "convertrecarea" string into architectural format:
; Change units from decimal to Architectural
(if *decimal*
(progn
(command "_.-units" "2" "" "" "" "" "")
(setq *decimal* nil)
)
(progn
(command "_.-units" "4" "" "" "" "" "")
(setq *decimal* t)
)
)
; create conditional "if/and" functions based on rectangle area in square inches.
; if area of rectangle below 14400 SQ.Inches, give message to redraw rectangle
(if
(<= myrecarea 14400)
(prompt "Area to small. Redraw area again")
); End IF
; if area of rectangle is between 14401 SQ.Inches and 57600 SQ.Inches, place a 24" circle at each corner of rectangle points
(if
(and
(>= myrecarea 14401)
(<= myrecarea 57600)
); End AND
(progn
(command "-color" "t" "99,100,102" ""); Change color
(command "circle" pt1 "d" 24 0 ""); Create circle
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 ""); Copy circle to all four points of rectangle
(setq circleset24 (ssget "_C" pt1 pt3 '((0 . "CIRCLE")))); Create selection set of circles using fencing around rectangle
(command "_hatch" "p" "AR-Conc" "2" "0" "s" circleset24 ""); Hatch selected circles
;Create rectangle from centerpoint. Copy to each corner
(command "-color" "t" "255,255,255" "")
(setq len 2)
(setq wid 2)
(setq z1 (trans '(0 0 1) 1 0 t))
(if (setq cnt1 pt1)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans (mapcar '+ cnt1 '(-2 -2)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 2 -2)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 2 2)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '(-2 2)) 1 z1))
(cons 210 z1)
)
)
)
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
); End Progn
); End IF
; if area of rectangle is between 57601 SQ.Inches and 129600 SQ.Inches, place a 36" circle at each corner of rectangle points
(if
(and
(>= myrecarea 57601)
(<= myrecarea 129600)
); End AND
(progn
(command "-color" "t" "99,100,102" "")
(command "circle" pt1 "d" 36 0 "")
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
(setq circleset36 (ssget "_C" pt1 pt3 '((0 . "CIRCLE"))))
(command "_hatch" "p" "AR-Conc" "2" "0" "s" circleset36 "")
;Create rectangle from centerpoint. Copy to each corner
(command "-color" "t" "255,255,255" "")
(setq len 3)
(setq wid 3)
(setq z1 (trans '(0 0 1) 1 0 t))
(if (setq cnt1 pt1)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans (mapcar '+ cnt1 '(-3 -3)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 3 -3)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 3 3)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '(-3 3)) 1 z1))
(cons 210 z1)
)
)
)
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
); End Progn
); End IF
; if area of rectangle is between 129601 SQ.Inches and 230400 SQ.Inches, place a 48" circle at each corner of rectangle points
(if
(and
(>= myrecarea 129601)
(<= myrecarea 230400)
); End AND
(progn
(command "-color" "t" "99,100,102" "")
(command "circle" pt1 "d" 48 0 "")
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
(setq circleset48 (ssget "_C" pt1 pt3 '((0 . "CIRCLE"))))
(command "_hatch" "p" "AR-Conc" "2" "0" "s" circleset48 "")
;Create rectangle from centerpoint. Copy to each corner
(command "-color" "t" "255,255,255" "")
(setq len 4)
(setq wid 4)
(setq z1 (trans '(0 0 1) 1 0 t))
(if (setq cnt1 pt1)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans (mapcar '+ cnt1 '(-4 -4)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 4 -4)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 4 4)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '(-4 4)) 1 z1))
(cons 210 z1)
)
)
)
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
); End Progn
); End IF
; if area of rectangle is above 230401 SQ.Inches tell user to redraw area
(if
(>= myrecarea 230401)
(prompt "Area to big. Redraw area again")
); End IF
(princ convertrecarea)
);End "concavearc"
新增功能正在运行，但我希望能够执行以下操作：
Put the Arc segment of code inside an "IF" Statement so if rectangle
drawn by user is too big or too small, prompt user "Out of range" and
end routine. Right now, it draws the arcs regardless if out of range.
我试图在下面输入一个 IF 语句，但没有成功。这是其中的一个片段：
(defun c:concavearc ( / b p q s z myrecarea convertrecarea pt1 pt2 pt3 pt4)
; ------------------ Create concave arcs from a rectangle----------
(setq s 20.0) ;; Arc sagitta
(if (and (setq p (getpoint "\nSpecify first corner: "))
(setq q ((if (zerop (getvar 'worlducs)) getpoint getcorner) p "\nSpecify opposite corner: "))
; Get the four points of rectangle drawn by user above
(setq pt1 p)
(setq pt3 q)
(setq pt2 (list (car pt1) (cadr pt3)))
(setq pt4 (list (car pt3) (cadr pt1)))
(setq mylength (distance pt1 pt2)); length
(setq mywidth (distance pt1 pt4)); width
(setq myrecarea (* mylength mywidth)); Get area of rectangle (length x width)
; If area drawn is above 129601square inches or below 14400 square inches display message the "not in range". Else, draw concave arcs.
(if
(and
(>= myrecarea 129601)
(<= myrecarea 14400)
); End and
(prompt "Not in range. Redraw area again")
(progn
Concave Arc code here....
);End Progn
);End "if/and" conditional statement
);End "get points"
只是一个内部问题。你如何输入平方英尺而不是英寸的数字？
示例：
(<= myrecarea 14400)
进入
(<= myrecarea 100 Sq. Ft.)
对于此任务，我建议使用如下函数：
(defun c:caverec ( / b p q s z )
(setq s 1.0) ;; Arc sagitta
(if (and (setq p (getpoint "\nSpecify first corner: "))
(setq q ((if (zerop (getvar 'worlducs)) getpoint getcorner) p "\nSpecify opposite corner: "))
(mapcar 'set '(p q) (mapcar '(lambda ( x ) (mapcar x p q)) '(min max)))
(setq z (trans '(0 0 1) 1 0 t)
b (mapcar '(lambda ( a b c ) (/ s (- a b) -0.5)) q p '(0 0))
)
)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans p 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car q) (cadr p)) 1 z))
(cons 042 (cadr b))
(cons 010 (trans q 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car p) (cadr q)) 1 z))
(cons 042 (cadr b))
(cons 210 z)
)
)
)
(princ)
)
这里，矩形四个边的弯曲度由代码顶部定义的单个参数s控制——这个参数对应圆弧的长度sagitta, 跨越每对顶点之间的圆弧中点与弦中点的距离。
代码提示用户指定对应于矩形对角的两个点，然后将继续构造一条封闭的 4 顶点 2D 折线 (LWPOLYLINE)，计算每个线段的凸度通过将 sagitta 除以弦长的一半（等于弧所跨角度的四分之一的正切，这是折线段凸起的定义 - 我更详细地描述了这种关系 here ).
代码获取相对于活动 UCS 的两个点，并计算相对于活动 UCS 的剩余两个顶点，然后将所有坐标转换为相对于对象坐标系 (OCS)。这意味着矩形将与活动 UCS 的 x 轴对齐，并将在 AutoCAD 中的所有 UCS 和视图设置下按预期运行。
函数使用getpoint函数在UCS不等于WCS时提示对角，避免使用getcorner引起的混淆，不尊重UCS 旋转。
生成的多段线将在当前图层上构建，继承在评估程序时处于活动状态的所有对象属性（颜色、线宽、线型等）。
(defun c:caverec ( / *error* acos newton postprocess cmd tst a b c d e f g l n p q r s w x z a1 a2 b1 b2 c1 c2 ii cmin cmax lw dx dy ll )
(defun *error* ( m )
(if command-s
(command-s "_.undo" "_e")
(vl-cmdf "_.undo" "_e")
)
(if cmd
(setvar 'cmdecho cmd)
)
(if m
(prompt m)
)
(princ)
)
(defun acos ( x )
(cond
( (equal x 1.0 1e-8) 0.0 )
( (equal x -1.0 1e-8) pi )
( (and (> x 0) (equal x 0.0 1e-8)) (/ pi 2.0) )
( (and (< x 0) (equal x -0.0 1e-8)) (* 3.0 (/ pi 2.0)) )
( (atan (sqrt (- 1.0 (* x x))) x) )
)
)
(defun newton ( chord arclen / k x ) ;; use the Newton method to compute the arc half angle acminording to its length and chord
(setq k (/ chord arclen)
x pi
)
(repeat 10
(setq x (- x (/ (- (sin x) (* k x)) (- (cos x) k))))
)
)
(defun n ( m c / r ) ;; n - area between arc and its chord ; m - sagitta of arc ; c - chord of arc
(if (> (setq r (/ (+ (expt m 2) (/ (expt c 2) 4.0)) (* 2.0 m))) m)
(-
(*
(* (expt r 2) pi)
(/ (acos (/ (- r m) r)) pi)
)
(*
(- r m)
(/ c 2.0)
)
)
(progn (prompt "\nr not bigger than m...") (exit))
) ;; if
) ;; Area between arc and its chord
(defun r ( c l / a ) ;; r - radius of arc ; c - chord of arc ; l - length of arc
;; (setq r (/ (+ (expt i 2) (expt (/ c 2) 4.0)) (* 2.0 i))) ;;; ( * )
;; (setq i (- r (sqrt (- (expt r 2) (/ (expt c 2) 4.0)))))
;; i^2+c^2/4=2*r^2(1-(cos(a/2))) ;; cosine theorem
;; i^2=2*r^2(1-(cos(a/2)))-c^2/4 ;;; ( 0 ) ;;;
;; ( * ) => r=(i^2+c^2/4)/(2*i)
;; r=(2*r^2(1-(cos(a/2)))-c^2/4+c^2/4)/(2*i)
;; r=r^2*(1-(cos(a/2)))/i
;; i=r*(1-(cos(a/2)))
;; i/r=1-cos(a/2)
;; cos(a/2)=1-i/r
;; a/2=acos(1-i/r)
;; a=2*acos(1-i/r)
;; <) = r^2*pi*(a/(2*pi))
;; <) = r^2*pi*2*acos(1-i/r)/(2*pi)
;; <) = r^2*acos(1-i/r)
;; |) = <) - <|
;; |) n = r^2*acos(1-i/r)-(r-i)*c/2 ;;; ( I ) ;;;
;; n=r^2*acos(1-i/r)-r*c/2+i*c/2
;; n=r^2*a/2-r*c/2+i*c/2 ;;; ( II ) ;;;
;; r^2*a/2-r*c/2+i*c/2-n=0
;; r=(c/2[+/-]sqrt(c^2/4-2*a*(i*c/2-n)))/a
;; ) = r*a=c/2+sqrt(c^2/4-a*i*c+2*a*n) ;; must be "+" [ ) is acways bigger than | ,pcus here is hacf of | ,so here this is especiaccy the case ] ;;; ( III ) ;;;
;; |> = i*c/2 ;;; ( IV ) ;;;
;; c'=sqrt(i^2+c^2/4) ;;; ( V ) ;;;
;; i'^2+c'^2/4=2*r^2(1-(cos(a/4))) ;; cosine theorem
;; ( V ) => i'^2+(i^2+c^2/4)/4=2*r^2(1-(cos(a/4)))
;; i'^2=2*r^2(1-(cos(a/4)))-(i^2+c^2/4)/4 ;;; ( VI ) ;;;
;; ( * ) => r=(i'^2+c'^2/4)/(2*i')
;; ( V ) => r=(i'^2+(i^2+c^2/4)/4)/(2*i')
;; ( VI ) => r=(2*r^2(1-(cos(a/4)))-(i^2+c^2/4)/4+(i^2+c^2/4)/4)/(2*i')
;; r=r^2(1-(cos(a/4))/i'
;; i'=r*(1-(cos(a/4))) ;;; ( VII ) ;;;
;; i'/r=1-cos(a/4)
;; cos(a/4)=1-i'/r
;; a/4=acos(1-i'/r)
;; a=4*acos(1-i'/r)
;; <) = r^2*pi*(a/(2*pi))
;; <) = r^2*pi*4*acos(1-i'/r)/(2*pi)
;; <) = 2*r^2*acos(1-i'/r)
;; ( I ) => /) = \) [ |) = <) - <| ] => n1=n2 = 2*r^2*acos(1-i'/r)-(r-i')*c'/2
;; ( V ) => n1=n2 = 2*r^2*acos(1-i'/r)-(r-i')*sqrt(i^2+c^2/4)/2 ;;; ( VIII ) ;;;
;; |) = n = |> + /) + \) <=> ( IV ) & ( VIII ) => n = i*c/2 + 4*r^2*acos(1-i'/r)-(r-i')*sqrt(i^2+c^2/4)/2
;; ( VII ) => n=i*c/2+4*r^2*acos(1-r*(1-(cos(a/4)))/r)-(r-r*(1-(cos(a/4))))*sqrt(i^2+c^2/4)/2
;; n=i*c/2+r^2*a/4-r*(cos(a/4))*sqrt(i^2+c^2/4)/2 ;;; ( IX ) ;;;
;; ( II ) & ( IX ) => n = r^2*a/2-r*c/2+i*c/2=i*c/2+r^2*a/4-r*(cos(a/4))*sqrt(i^2+c^2/4)/2
;; r^2*(a/4-a/2)+r*(c/2-(cos(a/4)*sqrt(i^2+c^2/4)/2))=0 |/r
;; -r*a/4+c/2-cos(a/4)*sqrt(i^2+c^2/4)/2=0 |*-4
;; r*a-2*c+2*cos(a/4)*sqrt(i^2+c^2/4)=0
;; r*a=2*(c-cos(a/4)*sqrt(i^2+c^2/4)) ;;; ( X ) ;;;
;; r=2*(c-cos(a/4)*sqrt(i^2+c^2/4))/a
;; ( 0 ) => r=2*(c-cos(a/4)*sqrt(2*r^2(1-(cos(a/2)))-c^2/4+c^2/4))/a
;; r=2*(c-cos(a/4)*sqrt(2)*r*sqrt(1-(cos(a/2))))/a |*(a/r)
;; a=2*(c-cos(a/4)*sqrt(2)*sqrt(1-(cos(a/2))))
;; a=2*c-2*sqrt(2)*cos(a/4)*sqrt(1-(cos(a/2)))
;; a=2*c-2*sqrt(2)*cos(a/4)*sqrt(1-((cos(a/4))^2-(sin(a/4))^2))
;; a=2*c-2*sqrt(2)*cos(a/4)*sqrt(2*(cos(a/4))^2)
;; a=2*c-4*(cos(a/4))^2
;; a+4*(cos(a/4))^2=2*c ; t=a/4
;; 4*t+4*(cos(t))^2=2*c |/4
;; t+(cos(t))^2=c/2
;; t=acos(sqrt(c/2-t))
(setq a (newton c l))
(setq r (abs (/ c 2.0 (sin a))))
) ;; Arc radius
(defun x ( e l1 l2 ii / n1 n2 )
(setq ii (- ii 0.01))
(setq n1 (n ii c1))
(setq n2 (n ii c2))
(setq r1 (/ (+ (expt ii 2) (expt (/ c1 2) 4.0)) (* 2.0 ii)))
(setq a1 (* 2.0 (acos (/ (- r1 ii) r1))))
(setq r2 (/ (+ (expt ii 2) (expt (/ c2 2) 4.0)) (* 2.0 ii)))
(setq a2 (* 2.0 (acos (/ (- r2 ii) r2))))
(if (< e (+ n1 n2))
(x e (l c1 a1 ii) (l c2 a2 ii) ii)
ii
)
)
(defun l ( c a i ) ;; l - length of arc ; c - chord of arc ; a - angle of arc ; i - sagitta of arc
(* 2.0
(-
c
(*
(cos (/ a 4.0))
(sqrt (+ (expt i 2) (/ (expt c 2) 4.0)))
)
)
)
)
(defun postprocess ( lw / lwx a1 a2 b1 b2 r1 r2 ii g loop dxf42 )
(setq lwx (entget lw))
(setq b1 (cdr (assoc 42 lwx)))
(setq b2 (cdr (assoc 42 (cdr (member (cons 42 b1) lwx)))))
(setq a1 (* 4.0 (atan b1)) a2 (* 4.0 (atan b2)))
(setq r1 (abs (/ c1 2.0 (sin (/ a1 2.0)))))
(setq r2 (abs (/ c2 2.0 (sin (/ a2 2.0)))))
(setq ii (- r1 (sqrt (- (expt r1 2) (/ (expt c1 2) 4.0)))))
(setq loop 1)
(prompt "\nleft mouse click for finish ; < - concaving ; > - convexing shape ; speed - type : 1,2,3,4,5,6,7,8,9...")
(while (/= (car (setq g (grread))) 3)
(if (and (= (car g) 2) (< 48 (cadr g) 58))
(progn (prompt "\nselected speed : ") (princ (setq loop (- (cadr g) 48))))
(repeat loop
(cond
( (equal g (list 2 60))
(setq ii (+ ii (* loop 0.01)))
)
( (equal g (list 2 62))
(setq ii (- ii (* loop 0.01)))
)
)
(setq b1 (/ ii c1 -0.5) b2 (/ ii c2 -0.5))
(setq dxf42 (vl-remove-if '(lambda ( x ) (/= (car x) 42)) lwx))
(entupd (cdr (assoc -1 (entmod (mapcar '(lambda ( x ) (cond ( (and (= (car x) 42) (= (rem (vl-position x dxf42) 2) 0)) (cons 42 b1) ) ( (and (= (car x) 42) (/= (rem (vl-position x dxf42) 2) 0)) (cons 42 b2) ) ( t x ))) lwx)))))
)
)
)
)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(if (equal 0 (getvar 'undoctl))
(vl-cmdf "_.undo" "_all")
)
(if
(or
(not (equal 1 (logand 1 (getvar 'undoctl))))
(equal 2 (logand 2 (getvar 'undoctl)))
) ;; or
(vl-cmdf "_.undo" "_control" "_all")
)
(if (equal 4 (logand 4 (getvar 'undoctl)))
(vl-cmdf "_.undo" "_auto" "_off")
)
(while (equal 8 (logand 8 (getvar 'undoctl)))
(vl-cmdf "_.undo" "_end")
)
(vl-cmdf "_.undo" "_begin")
(if
(and
(setq p (getpoint "\nPick or specify first corner : "))
(progn
(prompt "\nPick or specify opposite corner : ")
(while (= (car (setq g (grread t))) 5)
(setq q (cadr g))
(redraw)
(setq dx (- (car q) (car p)))
(setq dy (- (cadr q) (cadr p)))
(mapcar
'(lambda ( pair )
(grdraw (car pair) (cadr pair) 2 0)
)
(mapcar
'(lambda ( a b )
(mapcar
'(lambda ( c d )
(mapcar '+ c d)
)
a b
)
)
(repeat 4
(setq ll (cons (list p q) ll))
)
(list
(list (list 0 0) (list 0 (- dy)))
(list (list dx 0) (list 0 0))
(list (list dx dy) (list (- dx) 0))
(list (list 0 dy) (list (- dx) (- dy)))
)
)
)
)
q
)
(mapcar 'set '(p q) (mapcar '(lambda ( x ) (mapcar x p q)) '(min max)))
(setq c1 (- (car q) (car p)) c2 (- (cadr q) (cadr p)))
(setq cmin (min c1 c2) cmax (max c1 c2))
(setq z (trans '(0.0 0.0 1.0) 1 0 t))
(or
(progn
(while
(and
(not f)
(setq a
(cond
( (initget 6) )
( (setq a (getreal "\nArcs bulge angle in decimal degrees <90.0> : ")) )
( (prompt "\nArcs sagitta instead of angle : \nleft mouse click for \"Yes\" (sagitta input) / enter for \"No\" (proceed with 90.0 degree) : ") )
( t
(while
(and
(not (equal (setq g (grread)) (list 2 13)))
(/= (car g) 3)
)
)
(if (= (car g) 3)
(setq f nil a nil)
(progn (setq f t) 90.0)
)
)
)
)
(setq tst
(> a 90.0) ;; Adjacent arcs do not cross each other
)
(setq f (not tst))
(setq a (cvunit a "degree" "radian"))
(setq tst
(not
(<=
(- (/ (sin (/ a 4.0)) (cos (/ a 4.0))))
(/ (/ cmin 2.0) cmax -0.5)
0.0
)
) ;; Opposite arcs do not cross each other
)
(setq f (not tst))
) ;; and
) ;; Arcs bulge angle
a
)
(progn
(while
(and
(not f)
(setq s
(cond
( (initget 6) )
( (setq s (getdist "\nArcs sagitta <1.0> : ")) )
( (prompt "\nArcs by area instead of angle or sagitta : \nleft mouse click for \"Yes\" (area input) / enter for \"No\" (proceed with 1.0 sagitta distance) : ") )
( t
(while
(and
(not (equal (setq g (grread)) (list 2 13)))
(/= (car g) 3)
)
)
(if (= (car g) 3)
(setq f nil s nil)
(progn (setq f t) 1.0)
)
)
)
)
(setq tst
(> s (/ cmin 2.0)) ;; Opposite arcs do not cross each other
)
(not (setq f (not tst)))
) ;; and
(if tst
(prompt "\ntoo large sagitta... retry...")
)
) ;; Arcs sagitta
s
)
(progn
(while
(and
(not f)
(or
(setq tst
(not
(<=
(setq c
(-
(setq d (* c1 c2))
(* 2 (n (- (abs (/ c1 2.0 (sin (/ pi 4.0)))) (sqrt (- (expt (abs (/ c1 2.0 (sin (/ pi 4.0)))) 2) (/ (expt c1 2) 4.0)))) c1))
(* 2 (n (- (abs (/ c2 2.0 (sin (/ pi 4.0)))) (sqrt (- (expt (abs (/ c2 2.0 (sin (/ pi 4.0)))) 2) (/ (expt c2 2) 4.0)))) c2))
)
)
(setq w
(cond
( (initget 7) )
( (setq w (getreal (strcat "\nSpecify desired area from : " (rtos c 2 20) " to " (rtos d 2 20) " : ")))
w
)
)
)
d
)
) ;; Choosen area in valid range
)
(not (setq f (not tst)))
) ;; or
)
(prompt "\nInvalid area input...")
(setq f nil)
) ;; Area input
w
) ;; progn
) ;; or
(setq b
(cond
( a
(list (- (/ (sin (/ a 4.0)) (cos (/ a 4.0)))) (- (/ (sin (/ a 4.0)) (cos (/ a 4.0)))))
)
( s
(mapcar '(lambda ( c ) (/ s c -0.5)) (list c1 c2))
)
( w
(setq e (/ (- d w) 2.0))
(setq r1 (abs (/ c1 2.0 (sin (/ pi 4.0)))))
(setq ii (- r1 (sqrt (- (expt r1 2) (/ (expt c1 2) 4.0)))))
(setq a1 (* 2.0 (acos (/ (- r1 ii) r1))))
(setq r2 (abs (/ c2 2.0 (sin (/ pi 4.0)))))
(setq a2 (* 2.0 (acos (/ (- r2 ii) r2))))
(setq s (x e (l c1 a1 ii) (l c2 a2 ii) ii))
(mapcar '(lambda ( c ) (/ s c -0.5)) (list c1 c2))
)
)
)
) ;; and
(setq lw
(entmakex
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 038 (caddr (trans '(0.0 0.0 0.0) 1 z)))
(cons 010 (trans p 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car q) (cadr p)) 1 z))
(cons 042 (cadr b))
(cons 010 (trans q 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car p) (cadr q)) 1 z))
(cons 042 (cadr b))
(cons 210 z)
)
)
)
) ;; if
(prompt "\nleft mouse click to finish, enter to adjust with (grread)...")
(while
(and
(not (equal (setq g (grread)) (list 2 13)))
(/= (car g) 3)
)
(prompt "\nenter or left click...")
)
(if (/= (car g) 3)
(postprocess lw)
)
(*error* "\ndone...")
)
我想自动将用户绘制的矩形的所有边都转换成凹弧（周围大约 10 度）。 我发现这个由 Marko Ribar 编写的精彩例程（抱歉，如果这不是正确的信用）完全符合我的要求，除了用户必须使用鼠标手动定义弧的方向和度数。 推动鼠标正 Y 方向 = 凸。拉鼠标负 Y 方向 = 凹面（这是我想要的）。 有谁知道如何添加代码以在选择矩形后自动向负 Y 方向拉约 10 度？有没有更简单的方法来完成这个任务，在画矩形时只做 10 度的弧而不是直线？
;Code to convert rectangle lines into arcs:
(defun c:lwstraight2arced ( / nthmassocsubst lw enx vs gr enxb p b i pt1 pt2 pt3 pt4 myrec )
;My added code to draw a rectangle by the user picking two opposite corners-----------------
(setq pt1 (getpoint "\nEnter first corner: "))
(setq pt3 (getcorner pt1 "\nEnter cross corner: "))
(setq pt2 (list (car pt1) (cadr pt3)))
(setq pt4 (list (car pt3) (cadr pt1)))
(setq myrec (command "rectangle" pt1 pt3 ""))
;end of my added code------------------------
(defun nthmassocsubst ( n key value lst / k slst p j plst m tst pslst )
(setq k (length (setq slst (member (assoc key lst) lst))))
(setq p (- (length lst) k))
(setq j -1)
(repeat p
(setq plst (cons (nth (setq j (1+ j)) lst) plst))
)
(setq plst (reverse plst))
(setq j -1)
(setq m -1)
(repeat k
(setq j (1+ j))
(if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
(setq m (1+ m))
)
(if (and (not tst) (= n m))
(setq pslst (cons (cons key value) pslst) tst t)
(setq pslst (cons (nth j slst) pslst))
)
)
(setq pslst (reverse pslst))
(append plst pslst)
)
;
; ----removed original code that has user select a line or rectangle manually-----
; (setq lw (car (entsel "\nPick LWPOLYLINE straight polygon...")))
;-----end of original code-----
;-------My new code to have a previously drawn rectangle above automatically selected-----------------------------------
(setq lw (entlast))
;-----End of my new code------
(setq enx (entget lw))
(setq vs (getvar 'viewsize))
(while (= 5 (car (setq gr (grread t))))
(setq enxb (acet-list-m-assoc 42 enx))
(setq p (cadr gr))
(setq b (/ (cadr p) vs))
(setq i -1)
(foreach dxf42 enxb
(setq enx (nthmassocsubst (setq i (1+ i)) 42 b enx))
)
(entupd (cdr (assoc -1 (entmod enx))))
)
(princ)
)
这是我希望在用户绘制矩形后实现的。没有用户输入的略微凹陷的矩形。
我已将以下步骤添加到例程中：
-Get area of rectangle by multiplying length by width. -Draw circles and rectangles with a specific size at each corner based on square footage of rectangle in inches.
这是添加了上述内容的工作代码：
(defun c:concavearc ( / b p q s z myrecarea convertrecarea pt1 pt2 pt3 pt4 circleset24 circleset36 circleset48)
; Create concave arcs from a rectangle
(setq s 20.0) ;; Arc sagitta
(if (and (setq p (getpoint "\nSpecify first corner: "))
(setq q ((if (zerop (getvar 'worlducs)) getpoint getcorner) p "\nSpecify opposite corner: "))
(mapcar 'set '(p q) (mapcar '(lambda ( x ) (mapcar x p q)) '(min max)))
(setq z (trans '(0 0 1) 1 0 t)
b (mapcar '(lambda ( a b c ) (/ s (- a b) -0.5)) q p '(0 0))
)
)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans p 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car q) (cadr p)) 1 z))
(cons 042 (cadr b))
(cons 010 (trans q 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car p) (cadr q)) 1 z))
(cons 042 (cadr b))
(cons 210 z)
)
)
)
;Add width of 2" and dashed line to arc polyline -----------------------------------------
(setvar "cmdecho" 0); disable command echo
(setq Plnwdth (ssget "L"));get last entity
(command "pedit" Plnwdth "W" 2 "");set last entity width to 2
(if (null (tblsearch "ltype" "dashed"))
(command ".linetype" "load" "dashed" "acad.lin" "")
)
(command "change" Plnwdth "" "p" "LType" "Dashed" "" "ltScale" "30" "");lynetype
(setvar "cmdecho" 1); restore command echo
;end add width of 2 to arc polyline-----------------------------------------
;End concave arcs-----------------------------------------
;Setting corners of rectangle to variables --------------------------------------------------------------
; Get the four points of rectangle drawn by user above
(setq pt1 p)
(setq pt3 q)
(setq pt2 (list (car pt1) (cadr pt3)))
(setq pt4 (list (car pt3) (cadr pt1)))
(setq mylength (distance pt1 pt2)); length
(setq mywidth (distance pt1 pt4)); width
(setq myrecarea (* mylength mywidth)); Get area of rectangle (length x width)
(setvar "unitmode" 1);units to be displayed as entered
(setq convertrecarea (rtos myrecarea 4 2)); converts "convertrecarea" string into architectural format:
; Change units from decimal to Architectural
(if *decimal*
(progn
(command "_.-units" "2" "" "" "" "" "")
(setq *decimal* nil)
)
(progn
(command "_.-units" "4" "" "" "" "" "")
(setq *decimal* t)
)
)
; create conditional "if/and" functions based on rectangle area in square inches.
; if area of rectangle below 14400 SQ.Inches, give message to redraw rectangle
(if
(<= myrecarea 14400)
(prompt "Area to small. Redraw area again")
); End IF
; if area of rectangle is between 14401 SQ.Inches and 57600 SQ.Inches, place a 24" circle at each corner of rectangle points
(if
(and
(>= myrecarea 14401)
(<= myrecarea 57600)
); End AND
(progn
(command "-color" "t" "99,100,102" ""); Change color
(command "circle" pt1 "d" 24 0 ""); Create circle
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 ""); Copy circle to all four points of rectangle
(setq circleset24 (ssget "_C" pt1 pt3 '((0 . "CIRCLE")))); Create selection set of circles using fencing around rectangle
(command "_hatch" "p" "AR-Conc" "2" "0" "s" circleset24 ""); Hatch selected circles
;Create rectangle from centerpoint. Copy to each corner
(command "-color" "t" "255,255,255" "")
(setq len 2)
(setq wid 2)
(setq z1 (trans '(0 0 1) 1 0 t))
(if (setq cnt1 pt1)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans (mapcar '+ cnt1 '(-2 -2)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 2 -2)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 2 2)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '(-2 2)) 1 z1))
(cons 210 z1)
)
)
)
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
); End Progn
); End IF
; if area of rectangle is between 57601 SQ.Inches and 129600 SQ.Inches, place a 36" circle at each corner of rectangle points
(if
(and
(>= myrecarea 57601)
(<= myrecarea 129600)
); End AND
(progn
(command "-color" "t" "99,100,102" "")
(command "circle" pt1 "d" 36 0 "")
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
(setq circleset36 (ssget "_C" pt1 pt3 '((0 . "CIRCLE"))))
(command "_hatch" "p" "AR-Conc" "2" "0" "s" circleset36 "")
;Create rectangle from centerpoint. Copy to each corner
(command "-color" "t" "255,255,255" "")
(setq len 3)
(setq wid 3)
(setq z1 (trans '(0 0 1) 1 0 t))
(if (setq cnt1 pt1)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans (mapcar '+ cnt1 '(-3 -3)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 3 -3)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 3 3)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '(-3 3)) 1 z1))
(cons 210 z1)
)
)
)
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
); End Progn
); End IF
; if area of rectangle is between 129601 SQ.Inches and 230400 SQ.Inches, place a 48" circle at each corner of rectangle points
(if
(and
(>= myrecarea 129601)
(<= myrecarea 230400)
); End AND
(progn
(command "-color" "t" "99,100,102" "")
(command "circle" pt1 "d" 48 0 "")
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
(setq circleset48 (ssget "_C" pt1 pt3 '((0 . "CIRCLE"))))
(command "_hatch" "p" "AR-Conc" "2" "0" "s" circleset48 "")
;Create rectangle from centerpoint. Copy to each corner
(command "-color" "t" "255,255,255" "")
(setq len 4)
(setq wid 4)
(setq z1 (trans '(0 0 1) 1 0 t))
(if (setq cnt1 pt1)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans (mapcar '+ cnt1 '(-4 -4)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 4 -4)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '( 4 4)) 1 z1))
(cons 010 (trans (mapcar '+ cnt1 '(-4 4)) 1 z1))
(cons 210 z1)
)
)
)
(command "_copy" "last" "" "M" pt1 pt2 pt3 pt4 "")
); End Progn
); End IF
; if area of rectangle is above 230401 SQ.Inches tell user to redraw area
(if
(>= myrecarea 230401)
(prompt "Area to big. Redraw area again")
); End IF
(princ convertrecarea)
);End "concavearc"
新增功能正在运行，但我希望能够执行以下操作：
Put the Arc segment of code inside an "IF" Statement so if rectangle drawn by user is too big or too small, prompt user "Out of range" and end routine. Right now, it draws the arcs regardless if out of range.
我试图在下面输入一个 IF 语句，但没有成功。这是其中的一个片段：
(defun c:concavearc ( / b p q s z myrecarea convertrecarea pt1 pt2 pt3 pt4)
; ------------------ Create concave arcs from a rectangle----------
(setq s 20.0) ;; Arc sagitta
(if (and (setq p (getpoint "\nSpecify first corner: "))
(setq q ((if (zerop (getvar 'worlducs)) getpoint getcorner) p "\nSpecify opposite corner: "))
; Get the four points of rectangle drawn by user above
(setq pt1 p)
(setq pt3 q)
(setq pt2 (list (car pt1) (cadr pt3)))
(setq pt4 (list (car pt3) (cadr pt1)))
(setq mylength (distance pt1 pt2)); length
(setq mywidth (distance pt1 pt4)); width
(setq myrecarea (* mylength mywidth)); Get area of rectangle (length x width)
; If area drawn is above 129601square inches or below 14400 square inches display message the "not in range". Else, draw concave arcs.
(if
(and
(>= myrecarea 129601)
(<= myrecarea 14400)
); End and
(prompt "Not in range. Redraw area again")
(progn
Concave Arc code here....
);End Progn
);End "if/and" conditional statement
);End "get points"
只是一个内部问题。你如何输入平方英尺而不是英寸的数字？
示例：
(<= myrecarea 14400)
进入
(<= myrecarea 100 Sq. Ft.)
对于此任务，我建议使用如下函数：
(defun c:caverec ( / b p q s z )
(setq s 1.0) ;; Arc sagitta
(if (and (setq p (getpoint "\nSpecify first corner: "))
(setq q ((if (zerop (getvar 'worlducs)) getpoint getcorner) p "\nSpecify opposite corner: "))
(mapcar 'set '(p q) (mapcar '(lambda ( x ) (mapcar x p q)) '(min max)))
(setq z (trans '(0 0 1) 1 0 t)
b (mapcar '(lambda ( a b c ) (/ s (- a b) -0.5)) q p '(0 0))
)
)
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans p 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car q) (cadr p)) 1 z))
(cons 042 (cadr b))
(cons 010 (trans q 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car p) (cadr q)) 1 z))
(cons 042 (cadr b))
(cons 210 z)
)
)
)
(princ)
)
这里，矩形四个边的弯曲度由代码顶部定义的单个参数s控制——这个参数对应圆弧的长度sagitta, 跨越每对顶点之间的圆弧中点与弦中点的距离。
代码提示用户指定对应于矩形对角的两个点，然后将继续构造一条封闭的 4 顶点 2D 折线 (LWPOLYLINE)，计算每个线段的凸度通过将 sagitta 除以弦长的一半（等于弧所跨角度的四分之一的正切，这是折线段凸起的定义 - 我更详细地描述了这种关系 here ).
代码获取相对于活动 UCS 的两个点，并计算相对于活动 UCS 的剩余两个顶点，然后将所有坐标转换为相对于对象坐标系 (OCS)。这意味着矩形将与活动 UCS 的 x 轴对齐，并将在 AutoCAD 中的所有 UCS 和视图设置下按预期运行。
函数使用getpoint函数在UCS不等于WCS时提示对角，避免使用getcorner引起的混淆，不尊重UCS 旋转。
生成的多段线将在当前图层上构建，继承在评估程序时处于活动状态的所有对象属性（颜色、线宽、线型等）。
(defun c:caverec ( / *error* acos newton postprocess cmd tst a b c d e f g l n p q r s w x z a1 a2 b1 b2 c1 c2 ii cmin cmax lw dx dy ll )
(defun *error* ( m )
(if command-s
(command-s "_.undo" "_e")
(vl-cmdf "_.undo" "_e")
)
(if cmd
(setvar 'cmdecho cmd)
)
(if m
(prompt m)
)
(princ)
)
(defun acos ( x )
(cond
( (equal x 1.0 1e-8) 0.0 )
( (equal x -1.0 1e-8) pi )
( (and (> x 0) (equal x 0.0 1e-8)) (/ pi 2.0) )
( (and (< x 0) (equal x -0.0 1e-8)) (* 3.0 (/ pi 2.0)) )
( (atan (sqrt (- 1.0 (* x x))) x) )
)
)
(defun newton ( chord arclen / k x ) ;; use the Newton method to compute the arc half angle acminording to its length and chord
(setq k (/ chord arclen)
x pi
)
(repeat 10
(setq x (- x (/ (- (sin x) (* k x)) (- (cos x) k))))
)
)
(defun n ( m c / r ) ;; n - area between arc and its chord ; m - sagitta of arc ; c - chord of arc
(if (> (setq r (/ (+ (expt m 2) (/ (expt c 2) 4.0)) (* 2.0 m))) m)
(-
(*
(* (expt r 2) pi)
(/ (acos (/ (- r m) r)) pi)
)
(*
(- r m)
(/ c 2.0)
)
)
(progn (prompt "\nr not bigger than m...") (exit))
) ;; if
) ;; Area between arc and its chord
(defun r ( c l / a ) ;; r - radius of arc ; c - chord of arc ; l - length of arc
;; (setq r (/ (+ (expt i 2) (expt (/ c 2) 4.0)) (* 2.0 i))) ;;; ( * )
;; (setq i (- r (sqrt (- (expt r 2) (/ (expt c 2) 4.0)))))
;; i^2+c^2/4=2*r^2(1-(cos(a/2))) ;; cosine theorem
;; i^2=2*r^2(1-(cos(a/2)))-c^2/4 ;;; ( 0 ) ;;;
;; ( * ) => r=(i^2+c^2/4)/(2*i)
;; r=(2*r^2(1-(cos(a/2)))-c^2/4+c^2/4)/(2*i)
;; r=r^2*(1-(cos(a/2)))/i
;; i=r*(1-(cos(a/2)))
;; i/r=1-cos(a/2)
;; cos(a/2)=1-i/r
;; a/2=acos(1-i/r)
;; a=2*acos(1-i/r)
;; <) = r^2*pi*(a/(2*pi))
;; <) = r^2*pi*2*acos(1-i/r)/(2*pi)
;; <) = r^2*acos(1-i/r)
;; |) = <) - <|
;; |) n = r^2*acos(1-i/r)-(r-i)*c/2 ;;; ( I ) ;;;
;; n=r^2*acos(1-i/r)-r*c/2+i*c/2
;; n=r^2*a/2-r*c/2+i*c/2 ;;; ( II ) ;;;
;; r^2*a/2-r*c/2+i*c/2-n=0
;; r=(c/2[+/-]sqrt(c^2/4-2*a*(i*c/2-n)))/a
;; ) = r*a=c/2+sqrt(c^2/4-a*i*c+2*a*n) ;; must be "+" [ ) is acways bigger than | ,pcus here is hacf of | ,so here this is especiaccy the case ] ;;; ( III ) ;;;
;; |> = i*c/2 ;;; ( IV ) ;;;
;; c'=sqrt(i^2+c^2/4) ;;; ( V ) ;;;
;; i'^2+c'^2/4=2*r^2(1-(cos(a/4))) ;; cosine theorem
;; ( V ) => i'^2+(i^2+c^2/4)/4=2*r^2(1-(cos(a/4)))
;; i'^2=2*r^2(1-(cos(a/4)))-(i^2+c^2/4)/4 ;;; ( VI ) ;;;
;; ( * ) => r=(i'^2+c'^2/4)/(2*i')
;; ( V ) => r=(i'^2+(i^2+c^2/4)/4)/(2*i')
;; ( VI ) => r=(2*r^2(1-(cos(a/4)))-(i^2+c^2/4)/4+(i^2+c^2/4)/4)/(2*i')
;; r=r^2(1-(cos(a/4))/i'
;; i'=r*(1-(cos(a/4))) ;;; ( VII ) ;;;
;; i'/r=1-cos(a/4)
;; cos(a/4)=1-i'/r
;; a/4=acos(1-i'/r)
;; a=4*acos(1-i'/r)
;; <) = r^2*pi*(a/(2*pi))
;; <) = r^2*pi*4*acos(1-i'/r)/(2*pi)
;; <) = 2*r^2*acos(1-i'/r)
;; ( I ) => /) = \) [ |) = <) - <| ] => n1=n2 = 2*r^2*acos(1-i'/r)-(r-i')*c'/2
;; ( V ) => n1=n2 = 2*r^2*acos(1-i'/r)-(r-i')*sqrt(i^2+c^2/4)/2 ;;; ( VIII ) ;;;
;; |) = n = |> + /) + \) <=> ( IV ) & ( VIII ) => n = i*c/2 + 4*r^2*acos(1-i'/r)-(r-i')*sqrt(i^2+c^2/4)/2
;; ( VII ) => n=i*c/2+4*r^2*acos(1-r*(1-(cos(a/4)))/r)-(r-r*(1-(cos(a/4))))*sqrt(i^2+c^2/4)/2
;; n=i*c/2+r^2*a/4-r*(cos(a/4))*sqrt(i^2+c^2/4)/2 ;;; ( IX ) ;;;
;; ( II ) & ( IX ) => n = r^2*a/2-r*c/2+i*c/2=i*c/2+r^2*a/4-r*(cos(a/4))*sqrt(i^2+c^2/4)/2
;; r^2*(a/4-a/2)+r*(c/2-(cos(a/4)*sqrt(i^2+c^2/4)/2))=0 |/r
;; -r*a/4+c/2-cos(a/4)*sqrt(i^2+c^2/4)/2=0 |*-4
;; r*a-2*c+2*cos(a/4)*sqrt(i^2+c^2/4)=0
;; r*a=2*(c-cos(a/4)*sqrt(i^2+c^2/4)) ;;; ( X ) ;;;
;; r=2*(c-cos(a/4)*sqrt(i^2+c^2/4))/a
;; ( 0 ) => r=2*(c-cos(a/4)*sqrt(2*r^2(1-(cos(a/2)))-c^2/4+c^2/4))/a
;; r=2*(c-cos(a/4)*sqrt(2)*r*sqrt(1-(cos(a/2))))/a |*(a/r)
;; a=2*(c-cos(a/4)*sqrt(2)*sqrt(1-(cos(a/2))))
;; a=2*c-2*sqrt(2)*cos(a/4)*sqrt(1-(cos(a/2)))
;; a=2*c-2*sqrt(2)*cos(a/4)*sqrt(1-((cos(a/4))^2-(sin(a/4))^2))
;; a=2*c-2*sqrt(2)*cos(a/4)*sqrt(2*(cos(a/4))^2)
;; a=2*c-4*(cos(a/4))^2
;; a+4*(cos(a/4))^2=2*c ; t=a/4
;; 4*t+4*(cos(t))^2=2*c |/4
;; t+(cos(t))^2=c/2
;; t=acos(sqrt(c/2-t))
(setq a (newton c l))
(setq r (abs (/ c 2.0 (sin a))))
) ;; Arc radius
(defun x ( e l1 l2 ii / n1 n2 )
(setq ii (- ii 0.01))
(setq n1 (n ii c1))
(setq n2 (n ii c2))
(setq r1 (/ (+ (expt ii 2) (expt (/ c1 2) 4.0)) (* 2.0 ii)))
(setq a1 (* 2.0 (acos (/ (- r1 ii) r1))))
(setq r2 (/ (+ (expt ii 2) (expt (/ c2 2) 4.0)) (* 2.0 ii)))
(setq a2 (* 2.0 (acos (/ (- r2 ii) r2))))
(if (< e (+ n1 n2))
(x e (l c1 a1 ii) (l c2 a2 ii) ii)
ii
)
)
(defun l ( c a i ) ;; l - length of arc ; c - chord of arc ; a - angle of arc ; i - sagitta of arc
(* 2.0
(-
c
(*
(cos (/ a 4.0))
(sqrt (+ (expt i 2) (/ (expt c 2) 4.0)))
)
)
)
)
(defun postprocess ( lw / lwx a1 a2 b1 b2 r1 r2 ii g loop dxf42 )
(setq lwx (entget lw))
(setq b1 (cdr (assoc 42 lwx)))
(setq b2 (cdr (assoc 42 (cdr (member (cons 42 b1) lwx)))))
(setq a1 (* 4.0 (atan b1)) a2 (* 4.0 (atan b2)))
(setq r1 (abs (/ c1 2.0 (sin (/ a1 2.0)))))
(setq r2 (abs (/ c2 2.0 (sin (/ a2 2.0)))))
(setq ii (- r1 (sqrt (- (expt r1 2) (/ (expt c1 2) 4.0)))))
(setq loop 1)
(prompt "\nleft mouse click for finish ; < - concaving ; > - convexing shape ; speed - type : 1,2,3,4,5,6,7,8,9...")
(while (/= (car (setq g (grread))) 3)
(if (and (= (car g) 2) (< 48 (cadr g) 58))
(progn (prompt "\nselected speed : ") (princ (setq loop (- (cadr g) 48))))
(repeat loop
(cond
( (equal g (list 2 60))
(setq ii (+ ii (* loop 0.01)))
)
( (equal g (list 2 62))
(setq ii (- ii (* loop 0.01)))
)
)
(setq b1 (/ ii c1 -0.5) b2 (/ ii c2 -0.5))
(setq dxf42 (vl-remove-if '(lambda ( x ) (/= (car x) 42)) lwx))
(entupd (cdr (assoc -1 (entmod (mapcar '(lambda ( x ) (cond ( (and (= (car x) 42) (= (rem (vl-position x dxf42) 2) 0)) (cons 42 b1) ) ( (and (= (car x) 42) (/= (rem (vl-position x dxf42) 2) 0)) (cons 42 b2) ) ( t x ))) lwx)))))
)
)
)
)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(if (equal 0 (getvar 'undoctl))
(vl-cmdf "_.undo" "_all")
)
(if
(or
(not (equal 1 (logand 1 (getvar 'undoctl))))
(equal 2 (logand 2 (getvar 'undoctl)))
) ;; or
(vl-cmdf "_.undo" "_control" "_all")
)
(if (equal 4 (logand 4 (getvar 'undoctl)))
(vl-cmdf "_.undo" "_auto" "_off")
)
(while (equal 8 (logand 8 (getvar 'undoctl)))
(vl-cmdf "_.undo" "_end")
)
(vl-cmdf "_.undo" "_begin")
(if
(and
(setq p (getpoint "\nPick or specify first corner : "))
(progn
(prompt "\nPick or specify opposite corner : ")
(while (= (car (setq g (grread t))) 5)
(setq q (cadr g))
(redraw)
(setq dx (- (car q) (car p)))
(setq dy (- (cadr q) (cadr p)))
(mapcar
'(lambda ( pair )
(grdraw (car pair) (cadr pair) 2 0)
)
(mapcar
'(lambda ( a b )
(mapcar
'(lambda ( c d )
(mapcar '+ c d)
)
a b
)
)
(repeat 4
(setq ll (cons (list p q) ll))
)
(list
(list (list 0 0) (list 0 (- dy)))
(list (list dx 0) (list 0 0))
(list (list dx dy) (list (- dx) 0))
(list (list 0 dy) (list (- dx) (- dy)))
)
)
)
)
q
)
(mapcar 'set '(p q) (mapcar '(lambda ( x ) (mapcar x p q)) '(min max)))
(setq c1 (- (car q) (car p)) c2 (- (cadr q) (cadr p)))
(setq cmin (min c1 c2) cmax (max c1 c2))
(setq z (trans '(0.0 0.0 1.0) 1 0 t))
(or
(progn
(while
(and
(not f)
(setq a
(cond
( (initget 6) )
( (setq a (getreal "\nArcs bulge angle in decimal degrees <90.0> : ")) )
( (prompt "\nArcs sagitta instead of angle : \nleft mouse click for \"Yes\" (sagitta input) / enter for \"No\" (proceed with 90.0 degree) : ") )
( t
(while
(and
(not (equal (setq g (grread)) (list 2 13)))
(/= (car g) 3)
)
)
(if (= (car g) 3)
(setq f nil a nil)
(progn (setq f t) 90.0)
)
)
)
)
(setq tst
(> a 90.0) ;; Adjacent arcs do not cross each other
)
(setq f (not tst))
(setq a (cvunit a "degree" "radian"))
(setq tst
(not
(<=
(- (/ (sin (/ a 4.0)) (cos (/ a 4.0))))
(/ (/ cmin 2.0) cmax -0.5)
0.0
)
) ;; Opposite arcs do not cross each other
)
(setq f (not tst))
) ;; and
) ;; Arcs bulge angle
a
)
(progn
(while
(and
(not f)
(setq s
(cond
( (initget 6) )
( (setq s (getdist "\nArcs sagitta <1.0> : ")) )
( (prompt "\nArcs by area instead of angle or sagitta : \nleft mouse click for \"Yes\" (area input) / enter for \"No\" (proceed with 1.0 sagitta distance) : ") )
( t
(while
(and
(not (equal (setq g (grread)) (list 2 13)))
(/= (car g) 3)
)
)
(if (= (car g) 3)
(setq f nil s nil)
(progn (setq f t) 1.0)
)
)
)
)
(setq tst
(> s (/ cmin 2.0)) ;; Opposite arcs do not cross each other
)
(not (setq f (not tst)))
) ;; and
(if tst
(prompt "\ntoo large sagitta... retry...")
)
) ;; Arcs sagitta
s
)
(progn
(while
(and
(not f)
(or
(setq tst
(not
(<=
(setq c
(-
(setq d (* c1 c2))
(* 2 (n (- (abs (/ c1 2.0 (sin (/ pi 4.0)))) (sqrt (- (expt (abs (/ c1 2.0 (sin (/ pi 4.0)))) 2) (/ (expt c1 2) 4.0)))) c1))
(* 2 (n (- (abs (/ c2 2.0 (sin (/ pi 4.0)))) (sqrt (- (expt (abs (/ c2 2.0 (sin (/ pi 4.0)))) 2) (/ (expt c2 2) 4.0)))) c2))
)
)
(setq w
(cond
( (initget 7) )
( (setq w (getreal (strcat "\nSpecify desired area from : " (rtos c 2 20) " to " (rtos d 2 20) " : ")))
w
)
)
)
d
)
) ;; Choosen area in valid range
)
(not (setq f (not tst)))
) ;; or
)
(prompt "\nInvalid area input...")
(setq f nil)
) ;; Area input
w
) ;; progn
) ;; or
(setq b
(cond
( a
(list (- (/ (sin (/ a 4.0)) (cos (/ a 4.0)))) (- (/ (sin (/ a 4.0)) (cos (/ a 4.0)))))
)
( s
(mapcar '(lambda ( c ) (/ s c -0.5)) (list c1 c2))
)
( w
(setq e (/ (- d w) 2.0))
(setq r1 (abs (/ c1 2.0 (sin (/ pi 4.0)))))
(setq ii (- r1 (sqrt (- (expt r1 2) (/ (expt c1 2) 4.0)))))
(setq a1 (* 2.0 (acos (/ (- r1 ii) r1))))
(setq r2 (abs (/ c2 2.0 (sin (/ pi 4.0)))))
(setq a2 (* 2.0 (acos (/ (- r2 ii) r2))))
(setq s (x e (l c1 a1 ii) (l c2 a2 ii) ii))
(mapcar '(lambda ( c ) (/ s c -0.5)) (list c1 c2))
)
)
)
) ;; and
(setq lw
(entmakex
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 038 (caddr (trans '(0.0 0.0 0.0) 1 z)))
(cons 010 (trans p 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car q) (cadr p)) 1 z))
(cons 042 (cadr b))
(cons 010 (trans q 1 z))
(cons 042 (car b))
(cons 010 (trans (list (car p) (cadr q)) 1 z))
(cons 042 (cadr b))
(cons 210 z)
)
)
)
) ;; if
(prompt "\nleft mouse click to finish, enter to adjust with (grread)...")
(while
(and
(not (equal (setq g (grread)) (list 2 13)))
(/= (car g) 3)
)
(prompt "\nenter or left click...")
)
(if (/= (car g) 3)
(postprocess lw)
)
(*error* "\ndone...")
)