13648893846 发表于 2018-11-28 21:48:56

指定四点从第二点平分面积

(defun LC:TWO-ptlst-inters-lst (lst1 lst2 typ / ii jj pt1 pt2 pt3 pt4 azi intpt interpt)
   (setq ii (length lst1))
   (setq jj (length lst2))
;延长lst1左侧
(if (= (substr typ 1 1) "1")
    (progn
   (setq pt1 (nth 0 lst1))
   (setq pt2 (nth 1 lst1))
   (setq azi (angle pt1 pt2))
   (setq azi (+ pi azi))
   (setq lst1 (append (list (polar pt1 azi 10000) ) lst1 ))
    )
)
;延长lst1右侧
(if (= (substr typ 2 1) "1")
    (progn
   (setq pt1 (nth (1- ii) lst1))
   (setq pt2 (nth ii lst1))
   (setq azi (angle pt1 pt2))
   (setq lst1 (append lst1 (list (polar pt2 azi 10000) ) ))
    )
)
;延长lst2左侧
(if (= (substr typ 3 1) "1")
    (progn
   (setq pt3 (nth 0 lst2))
   (setq pt4 (nth 1 lst2))
   (setq azi (angle pt3 pt4))
   (setq azi (+ pi azi))
   (setq lst2 (append (list (polar pt3 azi 10000) ) lst2 ))
    )
)
;延长lst2右侧
(if (= (substr typ 4 1) "1")
    (progn
   (setq pt3 (nth (1- jj) lst2))
   (setq pt4 (nth jj lst2))
   (setq azi (angle pt3 pt4))
   (setq lst2 (append lst2 (list (polar pt4 azi 10000) ) ))
    )
)
;计算交点坐标
   (setq ii (1- (length lst1)))
   (setq jj (1- (length lst2)))
   (setq intpt nil interpt nil i 0 )
   (while (< i ii)
   (setq pt1 (nth i lst1))
   (setq pt2 (nth (1+ i) lst1))
   (setq j 0)
   (while (< j jj)
       (setq pt3 (nth j lst2))
       (setq pt4 (nth (1+ j) lst2))
       (setq intpt (inters pt1 pt2 pt3 pt4 t) )
       (if (/= intpt nil)
         ;将交点坐标存入点表
         (setq interpt (append interpt (list intpt)))
       )
       (setq j (1+ j))
   )
   (setq i (1+ i))
   )
interpt
)
(defun LINE:Offset (p1 p2 d / a)
(setq a (+ (angle p1 p2) (* pi 0.5)))
(list (polar p1 a d) (polar p2 a d))
)
(defun LC-point_line-DIST (pt pt1 pt2 / ptangle ptn pt pt1 pt2 dist jptx)
(setq ptangle(angle pt1 pt2)
      ptn      (polar pt (+ (* 0.5 pi) ptangle) 0.01)
      jptx   (inters pt ptn pt1 pt2 nil)
      dist   (distance pt jptx)
)
dist
)
(defun LC:Make-LWPOLYLINE (lst / PT)
(entmake (append (list '(0 . "LWPOLYLINE")
    '(100 . "AcDbEntity")
    '(100 . "AcDbPolyline")
    (cons 90 (length lst))
   )
   (mapcar '(lambda (pt) (cons 10 pt)) lst)
    )
)
)
(defun LC:4PT-Equal-area-pt(PTA PTB PTC PTD / PTO PTBD PTABCD X1 Y1 X2 Y2 X3 Y3 S DISOBD PTBDPY INTS)
(setq pto (mapcar (function (lambda (e1 e2) (* (+ e1 e2) 0.5))) pta ptc)) ;pta ptc中点
(setq ptbd (list ptb ptd)) ;对角线ptbptd
(setq ptabcd (list pta ptb ptc ptd pta)) ;四点点表
(LC:Make-LWPOLYLINE ptabcd)
;以下左右判断
(setq X1 (car ptb)
      Y1 (cadr ptb)
      X2 (car ptd)
      Y2 (cadr ptd)
      X3 (car pto)
      Y3 (cadr pto)
)
(setq s (- (* (- x1 x3) (- y2 y3)) (* (- y1 y3) (- x2 x3))))
(cond
   ((< s 0);右侧
(setq disobd (-(LC-point_line-DIST pto ptb ptd))) ;中点到对角线的距离
)
   ((> s 0);左侧
(setq disobd (LC-point_line-DIST pto ptb ptd))
)
)
(setq ptbdpy (LINE:Offset ptb ptd disobd)) ;过ptO点偏移后点表
(setq ints (LC:TWO-ptlst-inters-lst ptabcd ptbdpy "0"))
(LC:Make-LWPOLYLINE (list ptb (cadr ints)))
)
(defun c:sdpf (/ PTA PTB PTC PTD)
(setq pta (getpoint "\n 请选择第一点 ：")
      ptb (getpoint "\n 请选择第二点 ：")
      ptc (getpoint "\n 请选择第三点 ：")
      ptd (getpoint "\n 请选择第四点 ：")
)
(LC:4PT-Equal-area-pt pta ptb ptc ptd)
(princ "\n 运行命令 :sdpf")
(princ)
)


还请高人指点并提供通过四点内一点平分面积算法

mahuan1279 发表于 2018-12-3 16:50:25

四点构成的是凸四边形么？四点内一点是指四个顶点中的一个顶点么？要是的话，可以通过做图得出面积平分线。

13648893846 发表于 2018-12-4 00:52:40

不是四点中的一个端点

mahuan1279 发表于 2018-12-4 12:27:53

本帖最后由 mahuan1279 于 2018-12-4 12:30 编辑

13648893846 发表于 2018-12-4 00:52
不是四点中的一个端点
那么就是过凸四边形内一点作面积平分线了。http://bbs.xdcad.net/thread-706490-2-1.html

13648893846 发表于 2018-12-5 16:26:24

对就是这个效果
页: [1]
查看完整版本: 指定四点从第二点平分面积