;;[功能]pline,lwpline点坐标表  By 无痕
;;[用法](LC:WH-vxs (car (entsel))),返回三维点坐标
(defun LC:WH-vxs (e / i v lst)
  (setq i -1)
  (while
    (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
     (setq lst (cons v lst))
  )
  (reverse lst)
)

;[功能]生成射线
;[用法](LC:Entmake-XlineX (getpoint))
(defun LC:Entmake-XlineX (pt)
    (entmakeX (list '(0 . "XLINE")
                    '(100 . "AcDbEntity")
                    '(100 . "AcDbXline")
                    (cons 10 pt)
                    (cons 11 '(1 0 0))
              )
    )
  )

;[功能] 过一点射线与曲线的交点
;;示例(HH:XYCurvePt (car(entsel)) (getpoint) "X"),返回过一点X轴上的点
(defun HH:XYCurvePt (e1 pt Flag / E2 LST PTS)
  (setq e2 (LC:Entmake-XlineX pt))
  (setq pts (HH:TwoEntsInters e1 e2 0))
  (entdel e2)
  pts
)

;[功能]根据图元名及一点求X坐标以下部分面积
(defun LC:pts-2pt-area (ENT P1 / PTS2 INTS PTS PTS1)
  (setq pts2 '())
  (setq ints (HH:XYCurvePt ent p1 "X"));交点
  (setq pts (LC:WH-vxs ent));多段线顶点表
  (setq pts1 (vl-remove-if  '(lambda (x) (> (cadr x) (cadr p1))) pts))
  (setq pts2 (append pts2 ints pts1))
  (LC:getplarea pts2)
)

;[功能]根据图元名及一点求X坐标以上部分面积
(defun LC:pts-2pt-area1 (ENT P1 / PTS2 INTS PTS PTS1)
  (setq pts2 '())
  (setq ints (HH:XYCurvePt ent p1 "X"));交点
  (setq pts (LC:WH-vxs ent));多段线顶点表
  (setq pts1 (vl-remove-if  '(lambda (x) (< (cadr x) (cadr p1))) pts))
  (setq pts2 (append pts2 ints pts1))
  (abs (LC:getplarea pts2))
)

;[功能]点表求面积
 (defun LC:getplarea (l)
   (* 0.5
      (apply
        '+
        (mapcar
          '(lambda (a b) (- (* (car a) (cadr b)) (* (car b) (cadr a))))
          l
          (append (cdr l) (list (car l)))
        )
      )
   )
 )

;;[功能]点表生成多段线
(defun LC:Make-LWPOLYLINE1 (lst / PT)
  (entmake (append (list '(0 . "LWPOLYLINE")
    '(100 . "AcDbEntity")
    '(100 . "AcDbPolyline")
    '(62 . 1)
    (cons 90 (length lst))
     )
     (mapcar '(lambda (pt) (cons 10 pt)) lst)
    )
  )
)
;;;name:BF-list-delsame
;;;desc:删除表中相同元素，保留第一次出现的位置
;;;arg:lst:列表
;;;arg:buzz:容差
;;;return:删除重复元素组成的表
;;;example:(BF-list-delsame '(0 1 2 3 2 4 4) 0.1)---->(0 1 2 3 4)
(defun BF-list-delsame (lst buzz)
  (if Lst
    (cons (car Lst)
   (BF-list-delsame
     (vl-remove-if
       '(lambda (x) (equal (car lst) x buzz))
       (cdr lst)
     )
     buzz
   )
    )
  )
)
(defun HH:TwoEntsInters (e1 e2 Flag / OBJ1 OBJ2 PTL PTS)
  (setq obj1 (vlax-ename->vla-object e1))
  (setq obj2 (vlax-ename->vla-object e2))
  (setq pts (vlax-invoke obj1 'Intersectwith obj2 Flag))
  (while pts
    (setq ptl (cons (list (car pts) (cadr pts)) ptl))
    (setq pts (cdddr pts))
  )
  ptl
)

(defun c:mjhx1 (/ ENT PTS1 P1 P2 PT TZAREA AREA1 INTS)
  (princ "\n 二分法根据面积画线，可用于断面图计量人员使用")
  (setq ent (car (entsel "\n 请选择多段线: ")))    ;多段线顶点
  (setq pts1 (vl-sort (LC:WH-vxs ent) '(lambda (x y) (> (cadr x) (cadr y)))));点表按X值(测量坐标)从大到小排序
  (setq p1 (last pts1));X值最小点(CAD Y值)
  (setq p2 (car pts1));X值最大点(CAD Y值)
  (setq pt (list (car p1) (/ (+ (cadr p1) (cadr p2)) 2) 0.000));设定起始点
  (setq tzarea (getreal "\n 请输入多边形面积: "))
  (setq area1 0)
  (while (not (equal tzarea area1 0.0001))
    (setq ints (HH:XYCurvePt ent pt "X")) ;交点
    (setq area1 (abs(LC:pts-2pt-area ent pt)))
    (cond
      ((< area1 tzarea)   ;如果计算面积小于指定面积，
       (setq p1 pt)
      )
      ((> area1 tzarea)   ;如果计算面积大于指定面积，
       (setq p2 pt)
      )
     
    )
    (setq pt (list (car p1) (/ (+ (cadr p1) (cadr p2)) 2) 0.000))
  )
  (LC:Make-LWPOLYLINE1 ints)
  (princ)
)