cad绘制缓和曲线（命令为HH）

jxcaixiaomeng

;;多义线摹拟缓和曲线。
;;输入起止直线、半径、缓和曲线长或设计车速。
;;命令：HH，使用方法为把word转换到text，然后把后缀txt改为lsp
(defun com_p()  
  (setq l   0)
  (command "ucs" "o" (list (- 0 x1) 0 0))
  (command "pline" (list 0 0 0) "w" "0" ""
    (repeat 1000
      (setq l (+ l (/ Ls 1000))
            x (+ (- l (/ (* l l l l l) 40 C C)) (/ (* l l l l l l l l l) 3456 C C C C))
            y (* id__ (+ (- (/ (* l l l) 6 C) (/ (* l l l l l l l) 336 C C C)) (/ (* l l l l l l l l l l l) 42240 C C C C C)))
      );setq
      (command (list x y 0))
    );repaet
  );command  
  (setq pt5 (trans (list x y 0) 1 0))  
);com_p(defun ll_v()
  (setq V   (getreal "\nGive Velocity:")
        Ls1 (* V 0.85)
        Ls2 (/ (* 0.0357 V V V) R)
        Ls  (max Ls1 Ls2 (/ R 9))
        Ls  (* (fix (/ Ls 10)) 10.0)
  );setq
  (if (> Ls R) (setq Ls R))
  (ll_d)
);ll_v(defun ll_d()  
  (setq os (getvar "osmode"))
  (setvar "osmode" 0)  
  (setq C   (* Ls R)
        q   (- (+ (- (/ Ls 2) (/ (* Ls Ls Ls) 240 R R)) (/ (* Ls Ls Ls Ls Ls) 34560 R R R R)) (/ (* Ls Ls Ls Ls Ls Ls Ls) 8386560 R R R R R R))
        pt1 (cdr (assoc 10 (entget (car p1))))
        pt2 (cdr (assoc 11 (entget (car p1))))
        pt10(polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2))
        pt3 (cdr (assoc 10 (entget (car p2))))
        pt4 (cdr (assoc 11 (entget (car p2))))
        pt20(polar pt3 (angle pt3 pt4) (/ (distance pt3 pt4) 2))
        p   (+ (- (/ (* Ls Ls) 24 R) (/ (* Ls Ls Ls Ls) 2688 R R R)) (/ (* Ls Ls Ls Ls Ls Ls) 506880 R R R R R))
jd  (inters pt1 pt2 pt3 pt4 nil)
        alf1(angle pt10 jd)
        alf2(angle pt20 jd)
        alf (- (angle jd pt20) alf1)
  );setq  
  (if (or (> alf pi) (and (< alf 0) (> alf (- 0 pi))))
    (progn
      (setq id__ -1)
      (if (> alf pi) (setq alf (- (+ pi pi) alf)) (setq alf (abs alf)))
    );progn
    (progn
      (setq id__ 1)
      (if (<= alf (- 0 pi)) (setq alf (+ pi pi alf)))
    );progn
  );if
  (setq x0  (/ (* (+ p R) (sin(/ alf 2.0))) (cos(/ alf 2.0)))
        x1  (+ x0 q)
        Cl  (+ (*  alf R) Ls)
        E   (- (/ (+ R p) (cos(/ alf 2))) R)
  );setq  
  (command "ucs" "o" jd)
  (command "ucs" "z" (/ (* 180 alf1) pi))
  (com_p) (setq pt6 pt5)
  (setq ppt1 (list x1 0 0))  
  (command "ucs" "")  
  (command "ucs" "o" jd)
  (command "ucs" "z" (/ (* 180 alf2) pi))
  (setq id__ (- 0 id__)) (com_p)
  (setq ppt2 (list x1 0 0))  
  (command "ucs" "")
  (if (> (abs(distance jd pt1)) (abs(distance jd pt2)))
    (setq ptt1 pt1)
    (setq ptt1 pt2)
    );if
  (setq ptt2 (polar jd alf1 (- 0 x1)))  
  (thh p1 ptt1 10)
  (thh p1 ptt2 11)
  (if (> (abs(distance jd pt3)) (abs(distance jd pt4)))
    (setq ptt3 pt3)
    (setq ptt3 pt4)
    );if
  (setq ptt4 (polar jd alf2 (- 0 x1)))
  (thh p2 ptt3 10)
  (thh p2 ptt4 11)
  (if (= id__ 1) (command "arc" pt5 "e" pt6 "r" R) (command "arc" pt6 "e" pt5 "r" R))
  (setq alfd (angf alf))
  (setvar "osmode" os)  
  (command "cmdecho" "1")
  (command "text" pause pause "" (strcat "偏　　　角＝" alfd))
  (command "cmdecho" "0")
  (command "text" ""  (strcat "半　　　径＝" (rtos R 2 2)))
  (command "text" ""  (strcat "切　线　长＝" (rtos x1 2 2)))
  (command "text" ""  (strcat "曲　线　长＝" (rtos Cl 2 2)))
  (command "text" ""  (strcat "外　　　距＝" (rtos E 2 2)))
  (command "text" ""  (strcat "缓和曲线长＝" (rtos Ls 2 2)))
);ll_d
(defun angf (alf)
  (setq alff (angtos alf 1 4)
n 1
kk (strlen alff))
  (repeat kk
    (setq alfn (substr alff n 1))
    (if (= alfn "d")
      (setq nn n));if
    (setq n (+ n 1))
    );repeat
  (strcat (substr alff 1 (- nn 1)) "%%" (substr alff nn))
  );angf(defun c:hh(/ p1 p2 pt1 pt2 pt3 pt4 pt5 pt6 pt10 pt20 id__ R V Ls E p3
                r1 x y l x0 x1 C jd alf alf1 alf2 q p Cl Ls1 Ls2)
  (command "ucs" "")
  (setq p1 nil p2 nil)  
  (while (= p1 nil) (setq p1 (entsel "\n拾取第一条直线:")))
  (redraw (car p1) 3)
  (while (= p2 nil) (setq p2 (entsel "\n拾取第二条直线:")))
  (redraw (car p2) 3)
  (initget 1)
  (setq R (getdist "\n请输入弯道半径　R:  "))
  (initget 1 "Ls V")
  (setq p3 (getdist "\n输入缓和曲线长度(Ls)或[设计速度(V)]：  "))
  (if (= p3 "V") (ll_v) (progn (setq ls p3) (ll_d)))
  (princ)
);eline(defun thh(len pt h)
  (setq en_data (entget (car len))
        old_data (assoc h en_data)
new_data (cons h pt)
en (subst new_data old_data en_data));setq
  (entmod en)
  );thh