用LISP绘制精确的抛物线和双曲线

highflybird · 发表于 2021-9-5 01:15

本帖最后由 highflybird 于 2021-9-9 00:23 编辑

首先说一下，圆锥曲线在CAD中是有精确画法的。可以不用拟合方式或者很多个顶点的多段线模拟绘制。
这样绘制出来的抛物线是样条曲线，仅仅用三个控制点，就能满足高精度要求。
关于这个精确画法，请参考我的下面的帖子：
圆锥曲线在AutoCAD的精确表达法
因此根据这个画法，在这篇帖子里，对抛物线，我提供了三种画法的LISP程序：

下面是其动画演示：

三点式的核心代码如下：

;;;=============================================================
;;; 功能: 根据抛物线上三点获取抛物线方程系数
;;; 输入: 抛物线上三点p1,p2,p3 （点表，至少二维）
;;; 输出: 抛物线方程y=Ax^2+Bx+C的三个系数A,B,C
;;;=============================================================
(defun MATH:GetEquationBy3P (p1 p2 p3 / A B C D DX1 DX2 DX3 DY1
DY2 DY3 X1 X2 X3 Y1 Y2 Y3)
(mapcar 'set '(x1 x2 x3) (mapcar 'car (list p1 p2 p3)))
(mapcar 'set '(y1 y2 y3) (mapcar 'cadr (list p1 p2 p3)))
(if (not (GEO:Colinearity p1 p2 p3))
(setq dx1 (- x1 x2)
dx2 (- x2 x3)
dx3 (- x3 x1)
dy1 (- y1 y2)
dy2 (- y2 y3)
dy3 (- y3 y1)
dx1 (float dx1)
A (/ (- (* dx1 dy2) (* dx2 dy1)) (* dx1 dx2 dx3))
B (- (/ dy1 dx1) (* A (+ x1 x2)))
C (- y1 (* A x1 x1) (* B x1))
D (list A B C)
)
)
)
;;;=============================================================
;;; 功能: 根据抛物线系数获取圆锥曲线参数
;;; 输入: 抛物线系数a,b,c和上下界m,n以及相对点（插入点）
;;; 输出: 抛物线的两端点及其切线交点
;;;=============================================================
(defun MATH:GetArgumentsByEquation (a b c m n p / P1 P2 P3 Q1 Q3)
(setq p1 (list m (+ (* m m a) (* b m) c) 0.0))
(setq p3 (list n (+ (* n n a) (* b n) c) 0.0))
(setq q1 (polar p1 (atan (+ (* 2 a m) b)) 666))
(setq q3 (polar p3 (atan (+ (* 2 a n) b)) 666))
(setq p2 (inters p1 q1 p3 q3 nil))
(setq p1 (mapcar '+ p1 p))
(setq p2 (mapcar '+ p2 p))
(setq p3 (mapcar '+ p3 p))
(list p1 p2 p3 1)
)

;;;============================================================= 
;;; 功能: 根据抛物线上三点获取抛物线方程系数                     
;;; 输入: 抛物线上三点p1,p2,p3 （点表，至少二维）                
;;; 输出: 抛物线方程y=Ax^2+Bx+C的三个系数A,B,C                   
;;;============================================================= 
(defun MATH:GetEquationBy3P (p1 p2 p3 / A B C D DX1 DX2 DX3 DY1 
           DY2 DY3 X1 X2 X3 Y1 Y2 Y3) 
  (mapcar 'set '(x1 x2 x3) (mapcar 'car (list p1 p2 p3))) 
  (mapcar 'set '(y1 y2 y3) (mapcar 'cadr (list p1 p2 p3))) 
  (if (not (GEO:Colinearity p1 p2 p3)) 
    (setq dx1 (- x1 x2) 
    dx2 (- x2 x3) 
    dx3 (- x3 x1) 
    dy1 (- y1 y2) 
    dy2 (- y2 y3) 
    dy3 (- y3 y1) 
    dx1 (float dx1) 
    A (/ (- (* dx1 dy2) (* dx2 dy1)) (* dx1 dx2 dx3)) 
    B (- (/ dy1 dx1) (* A (+ x1 x2))) 
          C (- y1 (* A x1 x1) (* B x1)) 
          D (list A B C) 
    ) 
  ) 
) 
;;;============================================================= 
;;; 功能: 根据抛物线系数获取圆锥曲线参数                         
;;; 输入: 抛物线系数a,b,c和上下界m,n以及相对点（插入点）         
;;; 输出: 抛物线的两端点及其切线交点                            
;;;============================================================= 
(defun MATH:GetArgumentsByEquation (a b c m n p / P1 P2 P3 Q1 Q3) 
  (setq p1 (list m (+ (* m m a) (* b m) c) 0.0)) 
  (setq p3 (list n (+ (* n n a) (* b n) c) 0.0)) 
  (setq q1 (polar p1 (atan (+ (* 2 a m) b)) 666)) 
  (setq q3 (polar p3 (atan (+ (* 2 a n) b)) 666)) 
  (setq p2 (inters p1 q1 p3 q3 nil)) 
  (setq p1 (mapcar '+ p1 p)) 
  (setq p2 (mapcar '+ p2 p)) 
  (setq p3 (mapcar '+ p3 p)) 
  (list p1 p2 p3 1) 
)

其它具体实现细节请参见附件。

后续：此程序已经增加了双曲线的画法：
下面我继续介绍如何画双曲线：
经过研究，形成双曲线spline的三点对于P1,P3是容易得到的。对于P2点按照如下方式计算：

其中p2的权重取值为x/a.
其实当x取一些特殊值的时候，容易得到更简易的画法，譬如当x=2a的时候，以a=5,b=3为例，画法如下：

下面是用程序画出双曲线的演示：

代码在附件已经更新了。

注明：此代码开源，不得做商业用途。转载需注明出处。

xj6019 · 发表于 2021-9-5 08:39

膜拜大神，玩的66666

tigcat · 发表于 2021-9-5 11:34

tigcat 发表于 2021-9-5 11:31
看到高飞大神的这个抛物线,就想起了陈伯雄老师的正弦曲线程序.在他著作的P75
;陈老师;

;陈老师[code=lisp](Defun C:DSin ()
(SetQ x 0
n 100
z 1
s 1
dx (/ (* z 2 Pi) n)
)
(Command "pline" '(0 0))
(Repeat n
(SetQ x (+ x dx))
(Command (List x (* s (Sin x))))
)
(Command "")
)
;以下是可以填参数的
(Defun C:DSin (/ x n z s dx cm bl x0 y0)
(SetQ x 0
p (GetPoint "\n基点: ") x0 (Car p) y0 (Cadr p)
n (GetInt "\n精度(全线上直线片段数): ")
z (GetReal "\n周期数: ")
s (GetReal "\n波高系数: ")
dx (/ (* z 2 Pi) n)
)
(SetQ cm (GetVar "cmdecho") bl (GetVar "blipmode") os (GetVar "osmpde"))
(SetVar "cmdecho" 0) (SetVar "blipmode" 0) (SetVar "osmode" 0)
(Command "pline" p)
(Repeat n
(SetQ x (+ x dx))
(Command (List (+ x0 x) (+ y0 (* s (Sin x)))))
)
(Command "")
(SetVar "cmdecho" cm) (SetVar "blipmode" bl) (SetVar "osmode" os) (PrinC)
)

;陈老师[code=lisp](Defun C:DSin () 
       (SetQ x 0 
              n 100 
              z 1 
              s 1 
              dx (/ (* z 2 Pi) n) 
       ) 
       (Command "pline" '(0 0)) 
       (Repeat n 
                (SetQ x (+ x dx)) 
                (Command (List x (* s (Sin x)))) 
       ) 
       (Command "") 
) 
 
;以下是可以填参数的 
(Defun C:DSin (/ x n z s dx cm bl x0 y0) 
       (SetQ x 0 
             p (GetPoint "\n基点: ") x0 (Car p) y0 (Cadr p) 
             n (GetInt "\n精度(全线上直线片段数): ") 
             z (GetReal "\n周期数: ") 
             s (GetReal "\n波高系数: ") 
             dx (/ (* z 2 Pi) n) 
       ) 
       (SetQ cm (GetVar "cmdecho") bl (GetVar "blipmode") os (GetVar "osmpde")) 
       (SetVar "cmdecho" 0) (SetVar "blipmode" 0) (SetVar "osmode" 0) 
       (Command "pline" p) 
       (Repeat n 
               (SetQ x (+ x dx)) 
               (Command (List (+ x0 x) (+ y0 (* s (Sin x))))) 
                         
       ) 
       (Command "") 
       (SetVar "cmdecho" cm) (SetVar "blipmode" bl) (SetVar "osmode" os) (PrinC) 
)

[/code]

tigcat · 发表于 2021-9-5 11:31

本帖最后由 tigcat 于 2021-9-5 11:33 编辑

看到高飞大神的这个抛物线,就想起了陈伯雄老师的正弦曲线程序.在他著作的P75
;陈老师

(Defun C:DSin ()
(SetQ x 0
n 100
z 1
s 1
dx (/ (* z 2 Pi) n)
)
(Command "pline" '(0 0))
(Repeat n
(SetQ x (+ x dx))
(Command (List x (* s (Sin x))))
)
(Command "")
)
;以下是可以填参数的
(Defun C:DSin (/ x n z s dx cm bl x0 y0)
(SetQ x 0
p (GetPoint "\n基点: ") x0 (Car p) y0 (Cadr p)
n (GetInt "\n精度(全线上直线片段数): ")
z (GetReal "\n周期数: ")
s (GetReal "\n波高系数: ")
dx (/ (* z 2 Pi) n)
)
(SetQ cm (GetVar "cmdecho") bl (GetVar "blipmode") os (GetVar "osmpde"))
(SetVar "cmdecho" 0) (SetVar "blipmode" 0) (SetVar "osmode" 0)
(Command "pline" p)
(Repeat n
(SetQ x (+ x dx))
(Command (List (+ x0 x) (+ y0 (* s (Sin x)))))
)
(Command "")
(SetVar "cmdecho" cm) (SetVar "blipmode" bl) (SetVar "osmode" os) (PrinC)
)

(Defun C:DSin () 
       (SetQ x 0 
              n 100 
              z 1 
              s 1 
              dx (/ (* z 2 Pi) n) 
       ) 
       (Command "pline" '(0 0)) 
       (Repeat n 
                (SetQ x (+ x dx)) 
                (Command (List x (* s (Sin x)))) 
       ) 
       (Command "") 
) 
 
;以下是可以填参数的 
(Defun C:DSin (/ x n z s dx cm bl x0 y0) 
       (SetQ x 0 
             p (GetPoint "\n基点: ") x0 (Car p) y0 (Cadr p) 
             n (GetInt "\n精度(全线上直线片段数): ") 
             z (GetReal "\n周期数: ") 
             s (GetReal "\n波高系数: ") 
             dx (/ (* z 2 Pi) n) 
       ) 
       (SetQ cm (GetVar "cmdecho") bl (GetVar "blipmode") os (GetVar "osmpde")) 
       (SetVar "cmdecho" 0) (SetVar "blipmode" 0) (SetVar "osmode" 0) 
       (Command "pline" p) 
       (Repeat n 
               (SetQ x (+ x dx)) 
               (Command (List (+ x0 x) (+ y0 (* s (Sin x))))) 
                         
       ) 
       (Command "") 
       (SetVar "cmdecho" cm) (SetVar "blipmode" bl) (SetVar "osmode" os) (PrinC) 
)

;

纵横八方 · 发表于 2021-9-5 07:41

大师出手，就是不一样

mokson · 发表于 2021-9-5 08:21

玩得太高端了!!

print1985 · 发表于 2021-9-5 10:09

谢谢大神研究共享先顶再学

845245015 · 发表于 2021-9-5 10:55

tigcat · 发表于 2021-9-5 11:35

tigcat 发表于 2021-9-5 11:34
[/code]

不知为何defun后来出现这个链接地址,大家自己删下,我弄了几次没弄好,对不住了.

magicheno · 发表于 2021-9-5 13:35

太高端啦~~~感谢大神分享

账号		自动登录	找回密码
密码			注册

[【高飞鸟】] 用LISP绘制精确的抛物线和双曲线

本帖子中包含更多资源

评分