[弹指神通]：发几个以前写的曲线函数

LADESIGNER

特点是支持PLINE,LINE,ARC的数据列表，不一定要生成临时实体，算是对VL曲线函数的补充。
当时还处于从ALISP到VLISP的过渡阶段，感觉VLISP的曲线函数非要有实体才可以用，很不习惯，所以写了一啰哩啰嗦的一大堆。
有些函数用到了递归，不用写很多子函数，感觉挺紧凑的，呵呵。

[PHP]
;;**********************************************************************;;;
;;;_二维点转成三维点.                                                    ;;;
;;;参数: point                                                           ;;;
;;;返回:点                                                               ;;;
;;;**********************************************************************;;;
(defun DKL-Point2dTo3d(pt)
  (if (= (length pt) 2)
    (reverse (cons 0.0 (reverse pt)))
    pt
    )
  )
;;;**********************************************************************;;;
;;;_三维点转成二维点.                                                    ;;;
;;;参数: point                                                           ;;;
;;;返回:点                                                               ;;;
;;;**********************************************************************;;;
(defun DKL-Point3dTo2d(pt)
  (if (= (length pt) 3)
    (reverse (cdr(reverse pt)))
    pt
    )
  )
;;;**********************************************************************;;;
;;;_Pline线上某段转成直线或圆弧.                                         ;;;
;;;参数: (list (cons 10 pt) (cons 42 gxb) (cons 10 pt))                  ;;;
;;;返回: (list (cons 10 pt) (cons 11 pt))                                ;;;
;;;    或(list (cons 10 cen)(cons 40 rad)(cons 50 sang)(cons 51 eang)    ;;;
;;;**********************************************************************;;;
(defun DKL-Curve-PlineSeg(seg / BXC CEN EANG EPT GG GXB RAD SANG SPT TMPANG X Y TMP)
  (setq spt(DKL-point2dto3d(cdar seg))
        gxb(cdadr seg)
        ept(DKL-point2dto3d(cdaddr seg))
        )
  (if (or(equal gxb 0.0 1e-7)(equal spt ept 1e-7))
    (list '(0 . "LINE") (cons 10 spt) (cons 11 ept))
    (progn
      (setq bxc (/ (distance spt ept) 2)
            gg (* (abs gxb) bxc)
            rad(/ (+ (* bxc bxc) (* gg gg)) 2 gg)
            )
      (if (< gxb 0.0)
        (setq tmp spt spt ept ept tmp)
        )
      (setq cen(polar (mapcar '(lambda (x y) (/ (+ x y) 2)) spt ept)
                      (- (angle spt ept) pi_2)
                      (- gg rad)
                      )
                sang(rem (angle cen spt) (* pi 2))
                eang(rem (angle cen ept) (* pi 2))
                )
      (if (< sang 0.0)(setq sang (+ sang (* pi 2))))
      (if (< eang 0.0)(setq eang (+ eang (* pi 2))))
      (list
        '(0 . "ARC")
        (cons 10 cen)
        (cons 40 rad)
        (cons 50 sang)
        (cons 51 eang)
        )
      )
    )
  )
;;;**********************************************************************;;;
;;;_判断点是否在曲线上.                                                  ;;;
;;;参数: en---实体名或列表                                               ;;;
;;;返回:t or nil                                                         ;;;
;;;**********************************************************************;;;
(defun DKL-Curve-PtOn(en pt / ANG CEN EANG ENTYP EPT FLG GXB PT1 PT2 RAD SANG SEG SPT)
  (if (= (length pt) 2)
    (setq pt(DKL-point2dto3d pt))
    )
  (cond
    ((= (type en) 'ENAME)(if (vlax-curve-getparamatpoint (vlax-ename->vla-object en) pt) t nil))
    ((= (type en) 'VLA-OBJECT)(if (vlax-curve-getparamatpoint en pt) t nil))
    ((= (type en) 'LIST)
    (progn
      (setq entyp(cdr(assoc 0 en)))
      (cond
        ((= entyp "LINE")(progn
                           (setq spt(cdr(assoc 10 en))
                                 ept(cdr(assoc 11 en))
                                 )
                           (or
                             (equal pt spt 1e-7)
                             (equal pt ept 1e-7)
                             (and (or(equal (abs(- (angle spt ept) (angle pt ept))) 0 1e-7)
                                     (equal (abs(- (angle spt ept) (angle pt ept))) (* pi 2) 1e-7)
                                     )
                                  (>= (distance spt ept) (distance pt ept))
                                  )
                             )
                           )
         )
        ((= entyp "ARC")(progn
                          (setq cen(cdr(assoc 10 en))
                                rad(cdr(assoc 40 en))
                                sang(cdr(assoc 50 en))
                                eang(cdr(assoc 51 en))
                                )
                          (and
                            (equal (distance cen pt) rad 1e-7)
                            (setq ang(angle cen pt))
                            (if (> sang eang)
                              (or (<= sang ang (* pi 2))
                                   (>= eang ang 0)
                                   )
                              (>= eang ang sang)
                              )
                            )
                          )
         )
        ((= entyp "LWPOLYLINE")(progn
                                 (setq flg nil)
                                 (if (= (cdr(assoc 70 en)) 1)
                                   (setq en(reverse (cons (assoc 10 en) (reverse en))))
                                   )
                                 (while (and (null flg)
                                             (setq pt1(assoc 10 en)
                                                   en(cdr(member pt1 en))
                                                   gxb(assoc 42 en)
                                                   pt2(assoc 10 en))
                                                   )
                                   (setq seg(DKL-Curve-PlineSeg (list pt1 gxb pt2)))
                                   (setq flg (DKL-Curve-PtOn seg pt))
                                   )
                                 flg
                                 )
         )
        (t)
        )
      )
    )
    (t)
  )
  )
;;**********************************************************************;;;
;;;_获得曲线上某点的切线和法线角.                                        ;;;
;;;参数: en                                                              ;;;
;;;      pt                                                              ;;;
;;;                                                                      ;;;
;;;返回:(切线角度 法线角度)(wcs).                                        ;;;
;;;**********************************************************************;;;
(defun DKL-Curve-GetAngle(en pt / deriv tan normal ANG ANGS CEN EANG ENTYP EPT FIRSTDERIV GXB PT1 PT2 RAD SANG SEG SPT TMP)
  (cond
    ((= (type en) 'ENAME)(progn
                           (if (member (cdr(assoc 0 (entget en))) (list "LINE" "ARC" "CIRCLE" "LWPOLYLINE"))
                             (DKL-Curve-GetAngle (entget en) pt)
                             (progn
                               (setq
                                 en (vlax-ename->vla-object en)
                                 firstderiv(vlax-curve-getfirstderiv en (vlax-curve-getparamatpoint en pt))
                                 tan(angle '(0 0 0) firstderiv)
                                 normal(+ tan pi_2)
                                 )
                               (list tan normal)
                               )
                             )
                           )
     )
    ((= (type en) 'VLA-OBJECT)(DKL-Curve-GetAngle (vlax-vla-object->ename en) pt))
    ((= (type en) 'LIST)(progn
                          (setq entyp(cdr(assoc 0 en)))
                          (cond
                            ((= entyp "LINE")(progn
                                               (setq spt(cdr(assoc 10 en))
                                                     ept(cdr(assoc 11 en))
                                                     )
                                               (if (DKL-curve-pton (list '(0 . "LINE") (assoc 10 en) (assoc 11 en)) pt)
                                                 (setq tan(angle spt ept)
                                                       normal(+ tan pi_2)
                                                       )
                                                 )
                                                (list tan normal)
                                               )
                             )
                            ((= entyp "CIRCLE")(progn
                                                 (setq cen(cdr(assoc 10 en))
                                                       rad(cdr(assoc 40 en))
                                                       )
                                                 (if (equal (distance pt cen) rad 1e-7)
                                                   (setq normal(angle pt cen)
                                                         tan(- normal pi_2)
                                                         )
                                                   )
                                                  (list tan normal)
                                                 )
                             )
                            ((= entyp "ARC")(progn
                                              (setq cen(cdr(assoc 10 en))
                                                    rad(cdr(assoc 40 en))
                                                    sang(cdr(assoc 50 en))
                                                    eang(cdr(assoc 51 en))
                                                    )
                                              (if (and
                                                    (equal (distance cen pt) rad 1e-7)
                                                    (setq ang(angle cen pt))
                                                    (if (> sang eang)
                                                      (or (<= sang ang (* pi 2))
                                                           (>= eang ang 0)
                                                           )
                                                      (>= eang ang sang)
                                                      )
                                                    )
                                                (setq normal (+ pi ang)
                                                      tan(- normal pi_2)
                                                      )
                                                )
                                               (list tan normal)
                                              )
                             )
                            ((= entyp "LWPOLYLINE")(progn
                                                     (setq angs nil
                                                           ept(cdr(assoc 10 (reverse en)))
                                                           )
                                                     (if (= (cdr(assoc 70 en)) 1)(setq en(reverse (cons (assoc 10 en) (reverse en)))))
                                                     (while (and(setq pt1(assoc 10 en)
                                                                      gxb(assoc 42 en)
                                                                      en(cdr(member gxb en))
                                                                      pt2(assoc 10 en)
                                                                  )
                                                                )
                                                       (setq seg(DKL-Curve-PlineSeg (list pt1 gxb pt2)))
                                                       (princ seg)
                                                       (if (DKL-Curve-PtOn seg pt)
                                                         (progn
                                                           (setq tmp(DKL-Curve-Getangle seg pt)
                                                                 gxb(cdr gxb)
                                                                 )
                                                           (cond
                                                             ((> gxb 0.0)(setq tan(car tmp)normal(last tmp)))
                                                             ((< gxb 0.0)(setq tan(+ (car tmp) pi) normal(+ (last tmp) pi)))
                                                             (t(setq tan(car tmp) normal(last tmp)))
                                                             )
                                                           (if (equal pt1 pt2 1e-7)
                                                             (setq angs(cons (list 0   tan normal) angs))
                                                             (setq angs(cons (list 1  tan normal) angs))
                                                             )
                                                           )
                                                         )
                                                       )
                                                     (if (setq tmp(assoc 1 angs))
                                                       (cdr tmp)
                                                       (cdr(assoc 0 angs))
                                                       )
                                                     )
                             )
                            (t)
                            )
                          )
     )
    (t)
    )
)
;;;**********************************************************************;;;
;;;_获得曲线上已知距离的点坐标.                                          ;;;
;;;返回:点.                                                              ;;;
;;;**********************************************************************;;;
(defun DKL-Curve-GetPointAtDist(en dist / ANG CEN EANG ENTYP EPT GXB LEN PT PT1 PT2 RAD SANG SEG SPT TMP seglen)
  (cond
    ((< dist 0.0) nil)
    ((= (type en) 'ENAME)(vlax-curve-getpointatdist (vlax-ename->vla-object en) dist))
    ((= (type en) 'VLA-OBJECT)(vlax-curve-getpointatdist en dist))
    ((= (type en) 'LIST)
     (progn
       (setq entyp(cdr(assoc 0 en)))
       (cond
         ((= entyp "LINE")
          (progn
            (setq spt(cdr(assoc 10 en))
                  ept(cdr(assoc 11 en))
                  pt(polar spt (angle spt ept) dist)
                  )
            )
          (if (DKL-curve-pton en pt)
            pt
            nil
            )
          )
         ((= entyp "ARC")
          (progn
            (setq cen(cdr(assoc 10 en))
                  rad(cdr(assoc 40 en))
                  sang(cdr(assoc 50 en))
                  eang(cdr(assoc 51 en))
                  ang(/ dist rad)
                  ang(+ sang ang)
                  pt(polar cen ang rad)
                  )
            (if (DKL-curve-pton en pt)
              pt
              nil
              )
            )
          )
         ((= entyp "LWPOLYLINE")
          (progn
            (if (= (cdr(assoc 70 en)) 1)
              (setq en(reverse (cons (assoc 10 en)(reverse en))))
              )
              (while (setq pt1(assoc 10 en)
                           gxb(assoc 42 en)
                           en(cdr(member gxb en))
                           pt2(assoc 10 en)
                           )
                (setq seg(DKL-curve-plineseg (list pt1 gxb pt2))
                      seglen (DKL-curve-getlength seg)
                      dist(- dist seglen)
                      )
                (if (<= dist 0.0)
                  (setq pt(DKL-curve-getpointatdist seg (+ dist seglen))
                        en nil)
                  )
                )
            pt
            )
          )
         (t nil)
         )
       )
     )
    (t nil)
    )
  )
;;;**********************************************************************;;;
;;;_获得曲线上已知坐标点的距离.                                          ;;;
;;;参数: 实体名或LIST                                                    ;;;
;;;                                                                      ;;;
;;;                                                                      ;;;
;;;返回:距离.                                                            ;;;
;;;**********************************************************************;;;
(defun DKL-Curve-GetDistAtPoint(en pt / ANG CEN DIST EANG FLG GXB PT1 PT2 RAD SANG SEG TYP xang ptlen seglen)
  (cond
    ((= (type en) 'VLA-OBJECT)(vlax-curve-getdistatpoint en pt))
    ((= (type en) 'ENAME)(vlax-curve-getdistatpoint (vlax-ename->vla-object en) pt))
    ((= (type en) 'LIST)
     (progn
       (setq typ(cdr(assoc 0 en)))
       (cond
         ((= typ "LINE")(if (DKL-curve-pton en pt)(distance (cdr(assoc 10 en)) pt) nil))
         ((= typ "ARC")(if (DKL-curve-pton en pt)
                         (setq cen(cdr(assoc 10 en))
                               rad(cdr(assoc 40 en))
                               sang(cdr(assoc 50 en))
                               eang(cdr(assoc 51 en))
                               ang(angle cen pt)
                               xang(if (< ang sang)
                                     (+ (- (* pi 2) sang) ang)
                                     (- ang sang)
                                     )
                               dist(* xang rad)
                               )
                         nil
                         )
          )
         ((= typ "LWPOLYLINE")
          (progn
            (setq flg t
                  dist 0.0
                  )
            (if (= (cdr(assoc 70 en)) 1)
              (setq en(reverse (cons (assoc 10 en)(reverse en))))
              )
              (while (and(setq pt1(assoc 10 en)
                               gxb(assoc 42 en)
                               en(cdr(member gxb en))
                               pt2(assoc 10 en)
                               )
                         flg
                         )
                (setq seg(DKL-curve-plineseg (list pt1 gxb pt2))
                      seglen(DKL-curve-getlength seg)
                      )
                (if (DKL-curve-pton seg pt)
                  (setq ptlen(DKL-curve-getdistatpoint seg pt)
                        ptlen(if (< (cdr gxb) 0.0) (- seglen ptlen) ptlen)
                        dist(+ dist ptlen)
                        flg nil
                        )
                  (setq dist(+ dist seglen))
                  )
                )
            (if flg
              nil
              dist
              )
            )
          )
         (t nil)
         )
       )
     )
    (t nil)
    )
  )
;;;**********************************************************************;;;
;;;_获得用点模拟的曲线的点集.                                            ;;;
;;;参数: en实体名或表                                                            ;;;
;;;      fuzz 弦高差                                                     ;;;
;;;                                                                      ;;;
;;;返回:点表.                                                            ;;;
;;;**********************************************************************;;;
(defun DKL-Curve-GetSample(en fuzz / DIS ENTYP EPARAM EPT FLG MIDPT MIDPTONCUR PARAM PT PTS SPARAM SPT STEP X Y)
  (if (= (type en) 'ENAME)
    (setq en(vlax-ename->vla-object en))
    )
  (setq entyp(vla-get-objectname en)
        sparam(vlax-curve-getstartparam en)
        eparam(vlax-curve-getendparam en)
        step (/ fuzz 0.5)
        step(if (> (/ (- eparam sparam) step) 150)(setq step (/ (- eparam sparam) 150)) step)
        ept(vlax-curve-getendpoint en)
        flg t
        )
  (if (= entyp "AcDbPolyline")
      (progn
        (if (> step 1.0)
          (setq step 1.0)
          (setq step(/ 1.0 (fix (/ 1.0 step))))
          )
        )
    )
  (setq param (+ sparam step)
        spt(vlax-curve-getstartpoint en)
        pts(list spt)
        )
  (while (<= param (+ eparam 1e-7))
    (if (= entyp "AcDbPolyline")
      (progn
        (if (equal (fix param) param 1e-2)
          (setq param (fix param))
          )
        (if (equal (1+ (fix param)) param 1e-2)
          (setq param (1+ (fix param)))
          )
        (if (or(equal (fix param) param 1e-7)(equal (1+ (fix param)) param 1e-7))
          (setq spt(vlax-curve-getpointatparam en param)
                pts(append pts (list spt))
                sparam param
                flg nil)
          (setq flg t)
          )
        )
      )
   
    (if flg
      (progn
        (setq pt(vlax-curve-getpointatparam en param)
              midpt(mapcar '(lambda(x y)(/ (+ x y) 2)) spt pt)
              midptoncur(vlax-curve-getpointatparam en (/ (+ sparam param) 2))
              dis(distance midpt midptoncur)
              )
        (if (>= dis fuzz)
          (setq pts(append pts (list pt))
                sparam param
                spt pt
                )
          )
       
        )
      )
    (setq param(+ param step))
    )
  (if (not(equal param eparam 1e-7))
    (setq pts(append pts (list ept)))
    )
  pts
  )
[/PHP]既然其中还是vlax-curve 类，那就用到底最好！   eachy

sancher

顶