随机等高线加高程

树櫴希德 · 发表于 2017-8-3 09:21

本帖最后由树櫴希德于 2017-8-23 20:54 编辑

<div class="blockcode"><blockquote>(defun lst-(l1 l2)
(vl-remove-if'(lambda(x)(member x l2))l1))
(defun deld(lst d / a b c)
(while(setq a(mapcar'+(car lst)'(0 0))
b(vl-remove-if'(lambda(x)(>(distance a x)d))(cdr lst))
lst(lst-(cdr lst)b))
(setq c(cons b c))
)
(apply'append c))
(defun gcpzx (pt ss / pt ss k pzx name pt pl p2 pzx1 kk Name1 pzx2 pzx3 gcc juli1 juli2 bz xgc xzb)
;(setq PT(getPOINT "\n请点击点："))
;(setq dgj(getreal "\n请输入等高距："))
;(setq ss (ssget '((0 . "POLYLINE") (8 . "DSX,DGX"))))
(if ss
(progn
(setq k -1)
(setq pl '())
(repeat (sslength ss)
(setq Name (ssname ss (setq k (1+ k))) )
(setq pzx(distance (vl-remove (last pt) pt) (vl-remove (last (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name) PT [extend])) (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name) PT [extend]))
))
(setq pl (append pl (list pzx)))
) (setq p2 (vl-sort pl '<))
);;;;
);;;;;;===========
(if ss
(progn
(setq kk -1)
(repeat (sslength ss)
(setq Name1 (ssname ss (setq kk (1+ kk))) )
(setq pzx1(distance (vl-remove (last pt) pt) (vl-remove (last (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend])) (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend]))
))
(cond
((equal (car p2) pzx1 0.001) (setq pzx2 (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend]))
)
((equal (cadr p2) pzx1 0.001) (setq pzx3 (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend]))
)
)
)
(setq gcc (- (last pzx2) (last pzx3)))
(setq juli1 (distance (vl-remove (last pzx2) pzx2) (vl-remove (last pzx3) pzx3) ))
(setq juli2 (distance (vl-remove (last pt) pt) (vl-remove (last pzx3) pzx3) ))
(setq bz (/ gcc juli1))
(setq xgc (+ (last pzx3)(* bz juli2) ))
(setq xzb (list (car pt) (cadr pt) xgc))
);;;;
);;;;;;===========
xzb
);;;;;;;----------------------------------
;;;by Gu_xl
(defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
(setvar "CMDECHO" 0)
(command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" "" "")
(if height
(setq height (rtos height 2 3));3为高程注记位数
(setq height "")
)
(regapp "SOUTH")
;;;检查字体 "HZ" 是否存在
(if (not (tblobjname "style" "HZ"))
(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
)
;;;检查是否存在高程点图块定义
(if (not (tblobjname "block" "GC200"))
(progn
(setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
(setq obj
(vla-AddPolyline
blkdef
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 5))
'(-0.2 0 0 0.2 0 0)
)
)
)
)
(vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
(vla-put-Closed obj :vlax-true)
(vla-put-ConstantWidth obj 0.4)
)
)
;;;插入块
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1);;;属性跟随标志,1跟随，0不跟随
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
(list -3 '("SOUTH" (1000 . "202101")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
(cons 40 (* 2.0 scale))
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 height)
(cons 7 "HZ")
(cons 62 1)
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 70 0)
(cons 74 2)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)
;;;;;;;;;;;;;;;;;;;;
(defun RandList (a b n i / l r Rani)
(defun Rani (a b / tmp)
(if (not *Seed*)
(setq *Seed* (- (setq tmp (getvar "DATE")) (fix tmp)))
)
(+ a
(fix (* (- b a)
(setq
*Seed* (- (setq
tmp (/ (* *Seed* 1000000000 663608941)
1000000000.0
)
)
(fix tmp)
)
)
)
)
)
)
(cond
((or
(and (> (rem n (1+ (- b a))) 0)
(< i (1+ (/ n (1+ (- b a)))))
)
(and (= (rem n (1+ (- b a))) 0)
(< i (/ n (1+ (- b a))))
)
)
(prompt "\n没有满足要求的结果")
)
((and (= (rem n (1+ (- b a))) 0)
(= i (/ n (1+ (- b a))))
)
(repeat i
(setq l (cons a l))
)
(while (< a b)
(setq a (1+ a))
(repeat i
(setq l (cons a l))
)
)
(reverse l)
)
(t
(while (< (length l) n)
(setq r (Rani a b))
(if (< (- (length l) (length (vl-remove r l))) i)
(setq l (cons r l))
)
)
(reverse l)
)
)
)
;;测试: (f 1 100 40 1)
(defun rand(low top / a b)
(setq a(last(assoc(type low)'((int atoi)(real atof))))
b(+(*(- top low)(/(apply a(list(substr(rtos(getvar "cputicks"))8 3)))1000.))low)
b(if(equal a'atoi)(fix b)b))
)
;;;;;;;;;;;;;;;;;;;;;;;
(defun poinpl(p pt);;:点是否在指定点表内
(equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))
(defun plinexy(e)
(mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e)))
)
(defun c:sjgcd ( / ent11 pts ptlst ptlst1 e1 e2 minzb maxzb blc scale a b c n shuijishu i xzb yzb xinzb pzx123 xx)
(setq ent11 (car (entsel "\n请选择边界线：")))
(prompt "\n请选择等高线:")
(setq ss (ssget '((0 . "POLYLINE") (8 . "DSX,DGX"))))
(setq pts (plinexy ent11))
;(setq zfu (poinpl (getpoint "\n.......") pts))
(setq ptlst (vl-sort pts
;以下根据y坐标对表排序
'(lambda (e1 e2)
(< (cadr e1) (cadr e2) )
) ) )
(setq ptlst1 (vl-sort pts
;以下根据x坐标对表排序
'(lambda (e1 e2)
(< (car e1) (car e2) )
) ) )
(setq minzb (list (car(car ptlst1)) (cadr(car ptlst)) ) )
(setq maxzb (list (car(last ptlst1)) (cadr(last ptlst)) ) )
;(command "rectangle" minzb maxzb)
(vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
(setq blc (getint "\n请输入比例尺1:<500>"))
(if (= blc nil)(setq blc 500))
(setvar 'userr1 blc);设置比例尺
(setq scale (* 0.001 blc));缩放比例
;(setq a (getreal "\n随机数下限(不要超过3位小数):"))
; (setq b (getreal "\n随机数上限(不要超过3位小数):"))
(setq c (getint "\n随机数个数:"))
(setq n (getint "\n随机数最多重复次数:"))
;(command "_.units" "2" "8" "1" "8" "0" "n")
;(princ)
;(setvar "dimzin" 8)
;(setq shuijishu (RandList (* a (expt 10 3)) (* b (expt 10 3)) c n) )
; (setvar "dimzin" 0)
(setq i 0)(setq pzx123 '())
(repeat c
(if (and (setq xzb (car(randlist (* (atof (rtos (car minzb)2 3 ) ) 1000) (* (atof (rtos (car maxzb)2 3 ) ) 1000) c n) ))
(setq yzb (car(randlist (* (atof (rtos (cadr minzb)2 3 ) ) 1000) (* (atof (rtos (cadr maxzb)2 3 ) ) 1000) c n) ))
(= (poinpl (list (/ xzb 1000) (/ yzb 1000) ) pts) T)
)
(progn
(setq xinzb (gcpzx (list (/ xzb 1000) (/ yzb 1000) 0.000 ) ss))
(setq pzx123 (append (list xinzb) pzx123) )
(setq i (1+ i))
) )
)
(foreach xx (lst- pzx123 (deld pzx123 5.0000))
(gxl-cs:gcd xx (last xx) scale)
)
(princ)
)

<div class="blockcode"><blockquote>(defun lst-(l1 l2) 
(vl-remove-if'(lambda(x)(member x l2))l1)) 
 
(defun deld(lst d / a b c) 
  (while(setq a(mapcar'+(car lst)'(0 0)) 
        b(vl-remove-if'(lambda(x)(>(distance a x)d))(cdr lst)) 
        lst(lst-(cdr lst)b)) 
    (setq c(cons b c)) 
    ) 
  (apply'append c)) 
 
 
 
(defun gcpzx (pt ss / pt ss k pzx name pt pl p2 pzx1 kk Name1 pzx2 pzx3 gcc juli1 juli2 bz xgc xzb) 
;(setq PT(getPOINT "\n请点击点：")) 
;(setq dgj(getreal "\n请输入等高距：")) 
 
;(setq ss (ssget '((0 . "POLYLINE") (8 . "DSX,DGX")))) 
 
(if ss 
(progn 
  (setq k -1) 
(setq pl '()) 
(repeat (sslength ss) 
               (setq Name   (ssname ss (setq k (1+ k)))                       ) 
(setq pzx(distance (vl-remove  (last pt) pt)  (vl-remove  (last (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name) PT [extend])) (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name) PT [extend])) 
   )) 
  (setq pl (append pl (list pzx))) 
) (setq p2 (vl-sort pl '<)) 
 
   
  );;;; 
   
  );;;;;;=========== 
  (if ss 
(progn 
  (setq kk -1) 
 
(repeat (sslength ss) 
               (setq Name1   (ssname ss (setq kk (1+ kk)))                       ) 
  (setq pzx1(distance (vl-remove  (last pt) pt)  (vl-remove  (last (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend])) (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend])) 
   )) 
  (cond 
  ((equal (car p2) pzx1 0.001) (setq pzx2 (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend])) 
   ) 
  ((equal (cadr p2) pzx1 0.001) (setq pzx3 (vlax-curve-getClosestPointTo (vlax-ename->vla-object Name1) PT [extend])) 
   ) 
    ) 
 ) 
(setq gcc (- (last pzx2) (last pzx3))) 
  (setq juli1 (distance (vl-remove (last pzx2) pzx2) (vl-remove (last pzx3) pzx3)   )) 
  (setq juli2 (distance (vl-remove (last pt) pt) (vl-remove (last pzx3) pzx3)   )) 
  (setq bz (/ gcc juli1)) 
  (setq xgc (+ (last pzx3)(* bz juli2) )) 
  (setq xzb (list (car pt) (cadr pt) xgc)) 
  );;;; 
   
  );;;;;;=========== 
 
 
 xzb 
 
);;;;;;;---------------------------------- 
 
 
;;;by Gu_xl 
(defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数) 
  (setvar "CMDECHO" 0) 
  (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "") 
  (if height 
    (setq height (rtos height 2 3));3为高程注记位数 
    (setq height "") 
  ) 
  (regapp "SOUTH") 
   
  ;;;检查字体 "HZ" 是否存在 
  (if (not (tblobjname "style" "HZ")) 
    (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "") 
  ) 
  ;;;检查是否存在高程点图块定义 
  (if (not (tblobjname "block" "GC200")) 
    (progn 
      (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200")) 
      (setq obj 
        (vla-AddPolyline 
           blkdef 
           (vlax-make-variant 
              (vlax-safearray-fill 
                 (vlax-make-safearray vlax-vbdouble (cons 0 5)) 
                 '(-0.2 0 0 0.2 0 0) 
              ) 
           ) 
        ) 
      ) 
      (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1) 
      (vla-put-Closed obj :vlax-true) 
      (vla-put-ConstantWidth obj 0.4) 
    ) 
  ) 
  ;;;插入块 
  (entmake (list 
             '(0 . "INSERT") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockReference") 
             '(66 . 1);;;属性跟随标志,1跟随，0不跟随 
              (cons 2 "GC200") 
              (cons 10 inspt) 
              (cons 41 scale) 
              (cons 42 scale) 
              (cons 43 scale) 
              (list -3 '("SOUTH" (1000 . "202101"))) 
           ) 
  ) 
  ;;;插入属性 
  (entmake (list 
             '(0 . "ATTRIB") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbText") 
              (cons 10 (setq pt (polar inspt 0 (* 1.2 scale)))) 
              (cons 40 (* 2.0 scale)) 
              (cons 50 0) 
              (cons 41 0.8) 
              (cons 51 0) 
              (cons 1 height) 
              (cons 7 "HZ") 
       (cons 62 1) 
              (cons 72 0) 
              (cons 11 pt) 
              '(100 . "AcDbAttribute") 
              (cons 2 "height") 
              (cons 70  0) 
              (cons 74 2) 
           ) 
   ) 
   ;;;结束标志 
   (entmake '((0 . "SEQEND"))) 
   (princ) 
) 
 
;;;;;;;;;;;;;;;;;;;; 
(defun RandList (a b n i / l r Rani) 
  (defun Rani (a b / tmp) 
    (if        (not *Seed*) 
      (setq *Seed* (- (setq tmp (getvar "DATE")) (fix tmp))) 
    ) 
    (+ a 
       (fix (* (- b a) 
               (setq 
                 *Seed*        (- (setq 
                             tmp (/ (* *Seed* 1000000000 663608941) 
                                    1000000000.0 
                                 ) 
                           ) 
                           (fix tmp) 
                        ) 
               ) 
            ) 
       ) 
    ) 
  ) 
  (cond 
    ((or 
       (and (> (rem n (1+ (- b a))) 0) 
            (
       ) 
       (and (= (rem n (1+ (- b a))) 0) 
            (
       ) 
     ) 
     (prompt "\n没有满足要求的结果") 
    ) 
    ((and (= (rem n (1+ (- b a))) 0) 
          (= i (/ n (1+ (- b a)))) 
     ) 
     (repeat i 
       (setq l (cons a l)) 
     ) 
     (while (< a b) 
       (setq a (1+ a)) 
       (repeat i 
         (setq l (cons a l)) 
       ) 
     ) 
     (reverse l) 
    ) 
    (t 
     (while (< (length l) n) 
       (setq r (Rani a b)) 
       (if (< (- (length l) (length (vl-remove r l))) i) 
         (setq l (cons r l)) 
       ) 
     ) 
     (reverse l) 
    ) 
  ) 
) 
;;测试: (f 1 100 40 1) 
(defun rand(low top / a b) 
  (setq a(last(assoc(type low)'((int atoi)(real atof)))) 
 b(+(*(- top low)(/(apply a(list(substr(rtos(getvar "cputicks"))8 3)))1000.))low) 
 b(if(equal a'atoi)(fix b)b)) 
  ) 
;;;;;;;;;;;;;;;;;;;;;;; 
(defun poinpl(p pt);;:点是否在指定点表内 
  (equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8)) 
(defun plinexy(e) 
  (mapcar'cdr(vl-remove-if'(lambda(x)(/=(car x)10))(entget e))) 
  ) 
 
(defun c:sjgcd ( / ent11 pts ptlst ptlst1 e1 e2 minzb maxzb blc scale a b c n shuijishu i xzb yzb xinzb pzx123 xx) 
(setq ent11 (car (entsel "\n请选择边界线："))) 
  (prompt "\n请选择等高线:") 
 (setq ss (ssget '((0 . "POLYLINE") (8 . "DSX,DGX")))) 
(setq pts (plinexy ent11)) 
;(setq zfu (poinpl (getpoint "\n.......") pts)) 
(setq ptlst (vl-sort pts 
                   ;以下根据y坐标对表排序 
   '(lambda (e1 e2) 
            (< (cadr e1) (cadr e2) ) 
         )   )    ) 
 
(setq ptlst1 (vl-sort pts 
                   ;以下根据x坐标对表排序 
   '(lambda (e1 e2) 
            (< (car e1) (car e2) ) 
         )   )    ) 
 
(setq minzb (list (car(car ptlst1))  (cadr(car ptlst))                  )    ) 
(setq maxzb (list (car(last ptlst1))  (cadr(last ptlst))                  )    ) 
;(command "rectangle" minzb maxzb) 
  (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP 
     (setq blc (getint "\n请输入比例尺1:<500>")) 
  (if (= blc nil)(setq blc 500)) 
  (setvar 'userr1 blc);设置比例尺 
(setq scale (* 0.001 blc));缩放比例 
;(setq a (getreal "\n随机数下限(不要超过3位小数):")) 
          ; (setq b (getreal "\n随机数上限(不要超过3位小数):")) 
           (setq c (getint "\n随机数个数:")) 
           (setq n (getint "\n随机数最多重复次数:")) 
;(command "_.units" "2" "8" "1" "8"  "0" "n") 
;(princ) 
;(setvar "dimzin" 8) 
 
;(setq shuijishu (RandList  (* a (expt 10 3)) (* b (expt 10 3))  c n) ) 
 ; (setvar "dimzin" 0) 
 
(setq i 0)(setq pzx123 '()) 
(repeat c 
 
 (if   (and (setq xzb (car(randlist (* (atof (rtos (car minzb)2 3 ) )  1000) (* (atof (rtos (car maxzb)2 3 ) )  1000)  c n) )) 
            (setq yzb (car(randlist (* (atof (rtos (cadr minzb)2 3 ) )  1000) (* (atof (rtos (cadr maxzb)2 3 ) )  1000)  c n) )) 
   (= (poinpl (list (/ xzb 1000) (/ yzb 1000) ) pts)  T) 
   ) 
   (progn 
 (setq xinzb (gcpzx (list (/ xzb 1000) (/ yzb 1000) 0.000  ) ss)) 
 (setq pzx123 (append (list xinzb) pzx123)  ) 
    
   (setq i (1+ i)) 
   ) ) 
    ) 
  (foreach xx (lst- pzx123 (deld pzx123 5.0000)) 
 
    (gxl-cs:gcd  xx (last xx) scale) 
 
    ) 
   
(princ) 
)

shirllzz · 发表于 2017-8-10 06:56

我觉得不好，等高线还得依靠高程点，先后次序不能变，大多数情况下高程点不会丢失！

惊人的直觉 · 发表于 2017-8-11 12:02

lizhigang.jin 发表于 2017-8-3 15:28
命令: (LOAD "C:/Users/Administrator/Desktop/新建文本文档.lsp") ; 错误: no
function definition: 不 ...

你这个我提我也遇到了，请问你解决了吗？

惊人的直觉 · 发表于 2017-8-8 17:02

命令: (LOAD "C:/Users/Administrator/Desktop/新建文本文档.lsp") ; 错误: no
function definition: 不要超过3位小数

血司 · 发表于 2017-8-3 10:15

赞个赞个，就是有一点，加出来的点，分布可以在优化一下

lizhigang.jin · 发表于 2017-8-3 15:28

命令: (LOAD "C:/Users/Administrator/Desktop/新建文本文档.lsp") ; 错误: no
function definition: 不要超过3位小数

czb203 · 发表于 2017-8-5 20:13

楼主又出山了

419049759 · 发表于 2017-8-6 14:37

非常感谢！！

我需要高程值小数点后两位数，搞半天终于明白是RTOS这个函数

fangjcc · 发表于 2017-8-7 08:09

非常感谢，拷贝下来学习学习

crtrccrt · 发表于 2017-8-7 08:22

要随贴测试dwg文件

惊人的直觉 · 发表于 2017-8-8 17:04

血司发表于 2017-8-3 10:15
赞个赞个，就是有一点，加出来的点，分布可以在优化一下

怎么用的？我这边提示错误的

账号		自动登录	找回密码
密码			注册

随机等高线加高程

本帖子中包含更多资源

相关帖子