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

13648893846

(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

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

13648893846

不是四点中的一个端点

mahuan1279

13648893846 发表于 2018-12-4 00:52
不是四点中的一个端点

那么就是过凸四边形内一点作面积平分线了。http://bbs.xdcad.net/thread-706490-2-1.html

13648893846

对就是这个效果