断面线点表生成断面挖填点表
;;[功能]断面数据点表生成断面挖填点表;;[用法](LC:Section-line-ptlst-sort-lst ptlst1 ptlst2)
;;[作者]BY 老仓测绘上班记
;;;(setq ptlst1 (LC:WH-vxs (car (entsel"\n 请选择原始地貌线："))))
;;;(setq ptlst2 (LC:WH-vxs (car (entsel"\n 请选择设计j线："))))
;;;(PTLST1 PTLST2 / INTPTS ORIGINAL-INT DESIGN-INT I II ORIGINAL-INT-NEW JBLST WFLST TFLST INTPT DESIGN-INT1 ORIGINAL-INT1)
(defun LC:Section-line-ptlst-sort-lst (PTLST1 PTLST2 /)
(setq intpts (BF-list-delsame (LC:TWO-ptlst-inters-lst ptlst1 ptlst2 "0")0.001));交点表
(setq Original-int '() design-int '())
(setq Original-int (append Original-int ptlst1 intpts);原始地貌线总数据
design-int (append design-int ptlst2 intpts));设计线总数据
;交点及原始断面数据按Y值从小到大即断面图从左到右排序（Y值控制偏距）
(setq design-int (BF-list-delsame(vl-sort design-int '(lambda (x y) (> (car x) (car y))))0.001))
(setq Original-int (BF-list-delsame(vl-sort Original-int '(lambda (x y) (< (car x) (car y))))0.001))
(setq i 0 ii 0 Original-int-new '() wtfllst '() wflst '() tflst '())
(repeat (- (length intpts) 1)
(progn
(setq intpt1 (nth ii intpts));第ii个交点
(setq intpt2 (nth (+ ii 1) intpts));第ii个交点
(setq Original-int1 (vl-remove-if '(lambda (x) (or (<= (car x)(car(nth ii intpts))) (>= (car x)(car(nth (1+ ii) intpts))))) Original-int));原始断面线两交点之间的端点列表
(setq design-int1 (vl-remove-if '(lambda (x) (or (<= (car x)(car(nth ii intpts))) (>= (car x)(car(nth (1+ ii) intpts))))) design-int));设计线两交点之间的端点列表
;;; (setq jblst (append jblst (list (append (list intpt1) Original-int1 (list intpt2) design-int1))));把每段地面线数据及设计数据合并(append design-int1 design-int1 Original-int1)
(if (and (last design-int1) (or (> (cadr(nth ii intpts)) (cadr(last design-int1))) (> (cadr(nth (1+ ii) intpts)) (cadr(last design-int1)))))
(setq wflst (append wflst (list (append (list intpt1) Original-int1 (list intpt2) design-int1))))
(setq tflst (append tflst (list (append (list intpt1) Original-int1 (list intpt2) design-int1))))
)
)
(setq ii (1+ ii))
)
(setq wtfllst (append wtfllst (list wflst) (list tflst)));挖填总表
(princ wtfllst)
(princ)
)
有兴趣的可以移驾到下面的连结去看一下：
https://www.theswamp.org/index.php?topic=45305.15
;;; Cut & Fill by ymg ;
;;; ;
(defun c:cf (/ ** *acdoc* a are b bnd c cutcol d dir dl1 dl2 e fillcol hcol
intl len1 len2 p p0 p1 p2 pm pol1 pol2 sp1 sp2 spe ss1
ss2 totcut totfill txt txtlayer varl)
(vl-load-com)
(defun *error* (msg)
(mapcar 'eval varl)
(if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
(princ (strcat "\nError: " msg))
)
(and *acdoc* (vla-endundomark *acdoc*))
(princ)
)
(setq varl '("OSMODE" "CMDECHO" "DIMZIN" "PEDITACCEPT")
varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
)
(or *acdoc* (setq *acdoc* (vla-get-activedocument (vlax-get-acad-object))))
(vla-startundomark *acdoc*)
(setvar 'CMDECHO 0)
(setvar 'DIMZIN0)
(setvar 'OSMODE0)
(setq cutcol 1fillcol 3; Cut is Red, Fill is Green ;
totcut 0totfill 0; Total Cut and Total Fill ;
txtlayer "Text" ; Name of Layer for Cut and Fill Values ;
)
(while (not (setq **(princ "\nSelect Reference Polyline:")
ss1 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
)
)
(princ "\nYou Must Select a Polyline:")
)
(while (not (setq **(princ "\nSelect Proposed Polyline:")
ss2 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
)
)
(princ "\nYou Must Select a Polyline:")
)
(setq pol1 (ssname ss1 0)
len1 (vlax-curve-getDistAtParam pol1 (vlax-curve-getEndParam pol1))
pol2 (ssname ss2 0)
len2 (vlax-curve-getDistAtParam pol2 (vlax-curve-getEndParam pol2))
sp1(vlax-curve-getstartpoint pol1)
spe(vlax-curve-getendpoint pol1)
sp2(if (vlax-curve-isClosed pol2)
(setq lst2 (listpol pol2)
disl (mapcar '(lambda (a) (distance sp1 a)) lst2)
** (plineorg pol2 (nth (vl-position (apply 'min disl) disl) lst2))
)
(vlax-curve-getstartpoint pol2)
)
dir(if (< (/ pi 2) (angle sp1 spe) (/ (* 3 pi) 2)) -1 1)
)
; Getting all the intersections between poly. ;
(setq intl (intersections pol1 pol2))
(if (> (length intl) 1)
(progn
; Computing distance of intersections on each polyline ;
(setq dl1(mapcar '(lambda (a) (getdistoncurve pol1 a)) intl)
dl2(mapcar '(lambda (a) (getdistoncurve pol2 a)) intl)
)
; If both polyline are closed add first Intersection to end of list ;
; We also add a distance to each distances list ;
(if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))
(setq dl1(append dl1 (list (+ (car dl1) len1)))
dl2(append dl2 (list (+ (car dl2) len2)))
intl (append intl (list (car intl)))
dir(if (iscw_p (listpol pol1)) -1 1)
)
)
; Finding points at mid-distance between intersections on each polyline ;
; Calculating midpoint between mid-distance points to get an internal point;
; Creating a list of all these points plus the intersection points ;
(setq pm
(mapcar
'(lambda (a b c d e)
(list (midpoint
(setq p1 (getptoncurve pol1 (rem (* (+ a b) 0.5) len1)))
(setq p2 (getptoncurve pol2 (rem (* (+ c d) 0.5) len2)))
)
p1 p2 e
)
)
dl1 (cdr dl1) dl2 (cdr dl2) intl
)
)
(foreach i pm
(setqp (car i); Midpoint between p1 p2 ;
p0 (cadddr i); Intersection Point ;
p1 (cadr i); Midpoint of Intersections on Reference Polyline;
p2 (caddri); Midpoint of Intersections on Proposed Polyline ;
)
(if (> (abs (onside p2 p0 p1)) 1e-3) ; Not Colinear ;
(progn
(vl-cmdf "._-BOUNDARY" p "")
(setq are (vla-get-area (vlax-ename->vla-object (entlast)))
bnd (entlast)
)
(if (minusp (* (onside p2 p0 p1) dir))
(setq totfill (+ totfill are) hcol fillcol)
(setq totcut(+ totcutare) hcolcutcol)
)
(vl-cmdf "._-HATCH" "_CO" hcol "." "_P" "SOLID" "_S" bnd "" "")
(entdel bnd)
)
)
)
(setq p (cadr (grread nil 13 0))
txt (strcat "{\\C3;Fill: " (rtos totfill 2 2) " m2\\P\\C1;Cut: " (rtos totcut2 2) " m2}")
)
(entmakex (list
(cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 8 txtlayer)
(cons 100 "AcDbMText")
(cons 10 p)
(cons 40 3.0)
(cons 1 txt)
)
)
(command "_MOVE" (entlast) "" p pause)
)
(Alert "Not Enough Intersections To Process !")
)
(*error* nil)
)
(princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
(princ "\nCF to start...")
(defun midpoint (p1 p2)
(mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2)
)
; onside by ymg ;
; Negative return, point is on left of v1->v2 ;
; Positive return, point is on right of v1->v2 ;
; 0 return, point is smack on the vector. ;
; ;
(defun onside (p v1 v2 / x y)
(setq x (car p) y (cadr p))
(- (* (- (cadr v1) y) (-(car v2) x)) (* (- (carv1) x) (- (cadr v2) y)))
)
; ;
; Is Polyline Clockwise by LeeMac ;
; ;
; Argument: l,Point List ;
; Returns: t, Polyline is ClockWise ;
; nil, Polyline is CounterClockWise ;
; ;
(defun iscw_p (l)
(if (equal (car l) (last l) 1e-8) (setq l (cdr l)))
(minusp
(apply '+
(mapcar
(function
(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
)
l (cons (last l) l)
)
)
)
)
;; ;
;; Return list of intersection(s) between two VLA-Object or two ENAME ;
;; obj1 - first VLA-Object ;
;; obj2 - second VLA-Object ;
;; mode - intersection mode (acExtendNone acExtendThisEntity ;
;; acExtendOtherEntity acExtendBoth) ;
;; Requires triplet ;
;; ;
(defun Intersections (obj1 obj2)
(or (= (type obj1) 'VLA-OBJECT) (setq obj1 (vlax-ename->vla-object obj1)))
(or (= (type obj2) 'VLA-OBJECT) (setq obj2 (vlax-ename->vla-object obj2)))
(triplet (vlax-invoke obj1 'intersectwith obj2 acExtendNone))
)
;; ;
;; triplet, Separates a list into triplets of items. ;
;; ;
(defun triplet (l)
(if l (cons (list (car l) (cadr l) (caddr l))(triplet (cdddr l))))
)
(defun getdistoncurve (e p)
(vlax-curve-getDistatParam e
(vlax-curve-getparamatpoint e
(vlax-curve-getclosestpointto e p)
)
)
)
(defun getptoncurve (e d)
(vlax-curve-getpointatparam e (vlax-curve-getparamatdist e d))
)
;; ;
;; listpol by ymg (Simplified a Routine by Gile Chanteau ;
;; ;
;; Parameter:en,Entity Name or Object Name of Any Type of Polyline ;
;; ;
;; Returns: List of Points in Current UCS ;
;; ;
;; Notes: On Closed Polyline the Last Vertex is Same as First) ;
;; ;
(defun listpol (en / i l)
(repeat (setq i (fix (1+ (vlax-curve-getEndParam en))))
(setq l (cons (trans (vlax-curve-getPointAtParam en (setq i (1- i))) 0 1) l))
)
)
;; plineorg by (gile) (Modified into a function by ymg) ;
;;https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/ ;
;; change-polyline-start-point/td-p/2154331 ;
;; ;
;; Function to modify origin of a closed polyline ;
;; ;
;; Arguments: ;
;; en : Ename or VLA-Object of a Closed Polyline. ;
;; pt : Point ;
;; ;
;; Returns: Point of Origin if successful, else nil. ;
;; ;
(defun plineorg (en pt / blst d1 d2 d3 n norm obj pa plst)
(if (= (type en) 'ENAME)
(setq obj (vlax-ename->vla-objecten))
(setq obj en en (vlax-vla-object->ename obj))
)
;; bulgratio by (gile) ;
;; Returns a bulge which is proportional to a reference;
;; Arguments : ;
;; b : the reference bulge ;
;; k : the ratio (between angles or arcs length) ;
(defun bulgratio (b k / a)
(setq a (atan b))
(/ (sin (* k a)) (cos (* k a)))
)
;; Sublistby (gile) ;
;; Returns a sublist similar to substr function. ;
;; lst : List from which sublist is to be extracted ;
;; idx : Index of Item at Start of sublist ;
;; len : Length of sublist or nil to return all items. ;
(defun sublist (lst n len / rtn)
(if (or (not len) (< (- (length lst) n) len))
(setq len (- (length lst) n))
)
(setq n (+ n len))
(repeat len
(setq rtn (cons (nth (setq n (1- n)) lst) rtn))
)
)
(if (and (= (vla-get-closed obj) :vlax-true)
(= (vla-get-objectname obj) "AcDbPolyline")
)
(progn
(setq plst (vlax-get obj 'coordinates)
norm (vlax-get obj 'normal)
pt (vlax-curve-getClosestPointTo en (trans pt 1 0))
pa (vlax-curve-getparamatpoint obj pt)
n (/ (length plst) 2)
)
(repeat n
(setq blst (cons (vla-getbulge obj (setq n (1- n))) blst))
)
(if (= pa (fix pa))
(setq n (fix pa)
plst (append (sublist plst (* 2 n) nil)
(sublist plst 0 (* 2 n))
)
blst (append (sublist blst n nil) (sublist blst 0 n))
)
(setq n (1+ (fix pa))
d3 (vlax-curve-getdistatparam en n)
d2 (- d3 (vlax-curve-getdistatpoint en pt))
d3 (- d3 (vlax-curve-getdistatparam en (1- n)))
d1 (- d3 d2)
pt (trans pt 0 (vlax-get obj 'normal))
plst (append (list (car pt) (cadr pt))
(sublist plst (* 2 n) nil)
(sublist plst 0 (* 2 n))
)
blst (append (list (bulgratio (nth (1- n) blst) (/ d2 d3)))
(sublist blst n nil)
(sublist blst 0 (1- n))
(list (bulgratio (nth (1- n) blst) (/ d1 d3)))
)
)
)
(vlax-put obj 'coordinates plst)
(repeat (setq n (length blst))
(vla-setbulge obj (setq n (1- n)) (nth n blst))
)
(trans pt 0 1)
)
nil
)
)
;;[功能]两点表计算交点
;;[用法](LC:TWO-ptlst-inters-lst ptlst1 ptlst2 "0")
;;[作者]BY 老仓测绘上班记
;;说明:得到两个二维点表的交点
;;用非vla-IntersectWith方法不生成对象写的点表交点函数，可选多种延长方向，两点表都可以选择是否双向延长还是各自单向延长
;;参数:lst1:点表1
;;参数:lst2:点表2
;;参数:typ:延长类型（不区别大小写）："0000"或其他—两个都不延长;"0001"—延长点表2右侧两个点; "0010"—延长点表2左侧两个点； "0011"—延长点表2两侧两个点; "1000"—延长点表1左侧两个点; "0100"—延长点表1右侧两个点；"1100"—延长点表1两侧两个点;"1111"—延长点表1和点表2两侧两个点;
;;返回:符合条件的包括所有交点的二维点表
;;示例
;;;(setq ptlst1 (LC:WH-vxs (car (entsel"\n 请选择原始地貌线："))))
;;;(setq ptlst2 (LC:WH-vxs (car (entsel"\n 请选择设计j线："))))
;(setq lst1 (list (list 1492.5310 356.4799) (list 1693.9629 457.0300) (list 2085.9058 466.7216) (list 2281.2705 367.3829)))
;(setq lst2 (list (list 1567.8204 362.9696) (list 1667.2671324.9823) (list 1980.3360 258.3527) (list 2205.2348 357.8477)))
;(setq typ "0011")
;(LC:TWO-ptlst-inters-lst lst1 lst2 typ)
;((1532.53 376.449) (2255.92 380.272))
(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
)
;;;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
)
)
)
) 13648893846 发表于 2018-9-21 11:19
工作之余逐步写函数完善CASS任意断面法功能，太菜可能要很长一段时间
南方cass生成里程文件的时候，是按距离采样。不能按实际地形点采样。目前我已经写了一个根据图面实际高程点采样的插件 老仓老师最好是来个实例
好学习
本帖最后由 cnks 于 2018-9-14 12:57 编辑
xyp1964 发表于 2018-9-13 21:03
这个功能厉害，自动出工程量 函数不全，无法应用 欠缺的函数论坛都有 13648893846 发表于 2018-9-15 19:16
欠缺的函数论坛都有
搜过了，没找到
可以把老仓老师的这几个做成一个断面版块工具了 工作之余逐步写函数完善CASS任意断面法功能，太菜可能要很长一段时间
页:
[1]
2