明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: 革天明

求数据排序程序,数学上的排序

  [复制链接]
 楼主| 发表于 2012-4-25 13:01:10 | 显示全部楼层
革天明 发表于 2012-4-25 12:51
((2098.7 647.367) (2098.7 1073.41) (1824.61 1073.41) (1676.14 807.132) (1558.12 647.367))

请问如何修改才能实现呢?我改成(setq ptlist (list ((2098.7 647.367) (2098.7 1073.41) (1824.61 1073.41) (1676.14 807.132) (1558.12 647.367))))也不成功

点评

看9楼的点评  发表于 2012-4-25 13:16
 楼主| 发表于 2012-4-25 14:05:05 | 显示全部楼层
谢谢各位了,确实是数据本身的问题,数据来自于多段线顶点坐标,但求多段线顶点坐标的函数返回的不是表,谢谢各位了
发表于 2012-4-25 14:29:14 | 显示全部楼层
本帖最后由 xshrimp 于 2012-4-25 14:29 编辑

g版说的很清楚了啊.构造表不会.看看帮助啊.list
 楼主| 发表于 2012-4-25 15:39:58 | 显示全部楼层
自己编写的程序,用于将识别分界槽,并在分界槽处画线并打断,目前程序运行结果不正确,只能得到部分结果,




右侧红色线条为应该出现却未出现的线条(左侧为程序运行的结果,右侧为想实现的结果)
以下是代码部分:

;|求多段线的顶点坐标   引用自  明经  http://bbs.mjtd.com/forum.php?mod=viewthread&tid=89346&page=1#pid482397
在知道图元名的时候直接用(get-pline-point ent),返回如表((x1 y1 [z1])(x2 y2 [z2])(x3 y3 [z3])...)|;
(defun get-pline-point (ent / ptlist ptlist1)
  (vl-load-com)
  (setq ptlist '()
ptlist1 '()
n 0
  )
  (setq ptlist (vlax-safearray->list
   (vlax-variant-value
     (vlax-get-property
       (vlax-ename->vla-object ent)
       'Coordinates
     )
   )
        )
  )
  (cond
    (
     (= "LWPOLYLINE"
(cdr (assoc 0
      (entget ent)
      )
)
     )
     (progn
       (repeat (/ (length ptlist) 2)
  (setq ptlist1 (cons (list (nth n ptlist)
       (nth (setq n (1+ n)) ptlist)
        )
        ptlist1
         )
  )
  (setq n (1+ n))
       )
     )
    )
    (
     (= "POLYLINE"
(cdr (assoc 0
      (entget ent)
      )
)
     )
     (progn
       (repeat (/ (length ptlist) 3)
  (setq ptlist1 (cons (list (nth n ptlist)
       (nth (setq n (1+ n)) ptlist)
       (nth (setq n (1+ n)) ptlist)
        )
        ptlist1
         )
  )
  (setq n (1+ n))
       )
     )
    )
  )
(reverse ptlist1)
)     ;end defun get-pline-point
;|测试                     Gu_xl
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=93229&page=1#pid521103
(tst '(1 2 3 4 5 6) 3)
返回: '((1 2 3) (2 3 4) (3 4 5) (4 5 6) (5 6 1) (6 1 2))               |;
(defun Gu_xl_3p (l n / k nn)
  (setq k  -1
nn (length l)
  )
  (mapcar
    (function
      (lambda (a / ll m)
(setq k (1+ k)
       m k
)
(repeat n
   (setq ll (append ll (list (nth m l))))
   (setq m (rem (1+ m) nn))
   ll
)
      )
    )
    l
  )
)
;|命令: (tst (list 1 2 3 4 5 6))    xshrimp
((1 2 3) (2 3 4) (3 4 5) (4 5 6) (5 6 1) (6 1 2))|;
(defun xshrimp_3P (l / l2 l3)
  (setq l2 (append (cdr l) (list (car l)))
l3 (append (cdr l2) (list (car l2)))
  )
  (mapcar '(lambda (x y z) (list x y z)) l l2 l3)
)
;;;求最大最小坐标点 明经 ZZXXQQ 2008.12.11
(defun ZZXXQQ_tt ()
  (setq nm (if nm
      nm
      ""
    )
  )
  (if (setq nm (getfiled "选择数据文件" nm "*" 2))
    (progn
      (setq fp (open nm "r"))
      (setq maxx -1e6
     maxy maxx
     minx 1e6
     miny minx
      )
      (while (setq pt (read-line fp))
(setq pt (read (strcat "(" pt ")")))
(if (> (car pt) maxx)
   (setq maxx (car pt))
)
(if (> (cadr pt) maxy)
   (setq maxy (cadr pt))
)
(if (< (car pt) minx)
   (setq minx (car pt))
)
(if (< (cadr pt) miny)
   (setq miny (cadr pt))
)
      )
    )
  )
  (princ "\nMinPoint =")
  (princ (list minx miny))
  (princ "\nMaxPoint =")
  (princ (list maxx maxy))
  (princ)
)
;;;这要看你的数据是怎样组织的,或怎样表示的。
;;;如果将所有点组成一个表ptlist,而每个点的z坐标代表高程值,则
;;;   liu_kunlun   http://bbs.mjtd.com/forum.php?mod=viewthread&tid=53092&page=1#pid289602
;;;(apply 'max (mapcar '(lambda (x) (caddr x)) ptlist ))得到最大值
;;;(apply 'min (mapcar '(lambda (x) (caddr x)) ptlist ))得到最小值
(defun c:nb ()
  (SETVAR "CMDECHO" 0)
  ;;;生成多段线
  (COMMAND "PEDIT" "M" (SSGET) "" "Y" "J" "" "")
  (SETVAR "CMDECHO" 1)
  ;;;得到多段线的顶点坐标
  (setq nb-ptlist (get-pline-point (car (entsel))))
  ;;;求得所有坐标中最小的Y值
  (setq nb-miny(apply 'min (mapcar '(lambda (x) (cadr x)) nb-ptlist)))
  (setq nb-osmode (getvar "osmode"))
  (setvar "osmode" 0)
  ;;;对顶点坐标进行排序,生成三个坐标一组的表,分界槽由三点两线组成
  (setq nb-ptlist (Gu_xl_3p nb-ptlist 3))
  (setq i 0 k 0)
  (repeat (length nb-ptlist)
    (setq 3p (nth i nb-ptlist))
    ;;;用于对连续的三点进行计算,看是否满足分界槽的标准,分界槽是“少底边的等腰三角形”
    (if (= (distance (nth 0 3p) (nth 1 3p))
    (distance (nth 2 3p) (nth 1 3p))
)
        (progn
   (command "line" (list (* 0.5 (+ (car (nth 0 3p)) (car (nth 1 3p)))) (* 0.5 (+ (cadr (nth 0 3p)) (cadr (nth 1 3p)))))  (list (* 0.5 (+ (car (nth 0 3p)) (car (nth 1 3p)))) nb-miny)  "")
   (command "line" (list (* 0.5 (+ (car (nth 2 3p)) (car (nth 1 3p)))) (* 0.5 (+ (cadr (nth 2 3p)) (cadr (nth 1 3p)))))  (list (* 0.5 (+ (car (nth 2 3p)) (car (nth 1 3p)))) nb-miny)  "")
)
    );;;end if
    (setq i (1+ i))
  );;;end repeat
  (setvar "osmode" nb-osmode)
);;;end defun nb

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
 楼主| 发表于 2012-4-25 15:40:57 | 显示全部楼层
本帖最后由 革天明 于 2012-4-25 15:41 编辑

图片显示有点问题,点击一下可以放大而正常显示,谢谢各位对小弟的指点!
发表于 2012-4-25 16:28:10 | 显示全部楼层
比较两线的长短 (Dist)
要用 Equal 取代 = (总得要容差)

点评

长老,谢谢了,我设置容差为千分之一能正确运行,设置为千分之五时竟然还多画了两条线,谢谢你了!  发表于 2012-4-25 18:00
 楼主| 发表于 2012-4-26 10:30:36 | 显示全部楼层
本帖最后由 革天明 于 2012-4-26 10:33 编辑

程序想实现在“分界槽”处自动修剪,目前可以做到图中的第二步,想实现的是最右侧的效果,程序中trim命令执行起来没有效果,请指正。红色部分不能正确运行
(defun c:nb ()
  (SETVAR "CMDECHO" 0)
;;;生成多段线
  (COMMAND "PEDIT" "M" (SSGET) "" "Y" "J" "" "")
  (SETVAR "CMDECHO" 1)
;;;得到多段线的顶点坐标
  (setq nb-entsel (car (entsel)))
  (setq nb-ptlist (get-pline-point nb-entsel))
;;;求得所有坐标中最小的Y值
  (setq nb-miny (apply 'min (mapcar '(lambda (x) (cadr x)) nb-ptlist)))
  (setq nb-osmode (getvar "osmode"))
  (setvar "osmode" 0)
;;;对顶点坐标进行排序,生成三个坐标一组的表,分界槽由三点两线组成
  (setq nb-ptlist (Gu_xl_3p nb-ptlist 3))
  (setq        i 0
        k 0
  )
  (repeat (length nb-ptlist)
    (setq 3p           (nth i nb-ptlist)
          nb-3p-p1 (nth 0 3p)
          nb-3p-p2 (nth 1 3p)
          nb-3p-p3 (nth 2 3p)
    )
;;;用于对连续的三点进行计算,看是否满足分界槽的标准,分界槽是“少底边的等腰三角形”
    (if        (equal (distance nb-3p-p1 nb-3p-p2)
               (distance nb-3p-p3 nb-3p-p2)
               (* 0.001 (distance nb-3p-p1 nb-3p-p2))
        )
      (progn
        (command
          "line"
          (mpt nb-3p-p1 nb-3p-p2)
          (list (car (mpt nb-3p-p1 nb-3p-p2)) nb-miny)
          ""
        )
        (command
          "line"
          (mpt nb-3p-p2 nb-3p-p3)
          (list (car (mpt nb-3p-p2 nb-3p-p3)) nb-miny)
          ""
        )
;;;计算两点间的中点,mpt是求中点的函数
        (setq nb-cut-pt1 (mpt (mpt nb-3p-p1 nb-3p-p2) nb-3p-p2)
              nb-cut-pt2 (mpt (mpt nb-3p-p3 nb-3p-p2) nb-3p-p2)
              nb-cut-pt3 (list (car nb-3p-p2) nb-miny)
        )
        (command "trim" "" "" (cons (ssname (ssget nb-cut-pt1) 0) (list nb-cut-pt1)) "")
        (command "trim" "" "" (cons (ssname (ssget nb-cut-pt2) 0) (list nb-cut-pt2)) "")
        (command "trim" "" "" (cons (ssname (ssget nb-cut-pt3) 0) (list nb-cut-pt3)) "")
      )
    )
;;;end if
    (setq i (1+ i))
  )
;;;end repeat
  (setvar "osmode" nb-osmode)
)
;;;end defun nb

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
 楼主| 发表于 2012-4-26 10:32:36 | 显示全部楼层
程序目前以“只有一个分界槽”来写的trim,后期可以将trim语句写在另外一个repeat中,
发表于 2012-4-26 11:18:17 | 显示全部楼层
本帖最后由 qjchen 于 2012-4-26 11:19 编辑
xshrimp 发表于 2012-4-24 18:48
命令: (tst (list 1 2 3 4 5 6))
((1 2 3) (2 3 4) (3 4 5) (4 5 6) (5 6 1) (6 1 2))

gu兄和xshrimp兄都是好方法:)

也凑下热闹写一个递归的


  1. (defun q:lst2(lst)
  2. (q:lst1 (append lst (list (car lst) (cadr lst))))
  3. )

  4. (defun q:lst1(lst)
  5.   (cond ((not (caddr lst)) nil)
  6.         (T (cons (list (car lst) (cadr lst) (caddr lst)) (q:lst1 (cdr lst))))
  7.   )
  8. )

  9. (q:lst2 (list 1 2 3 4 5 6))

评分

参与人数 2明经币 +2 收起 理由
xshrimp + 1 赞一个!
Gu_xl + 1 赞一个!

查看全部评分

发表于 2012-4-26 14:32:03 | 显示全部楼层
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-24 06:39 , Processed in 0.182802 second(s), 20 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表