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

革天明 · 发表于 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))))也不成功

革天明 · 发表于 2012-4-25 14:05:05

谢谢各位了，确实是数据本身的问题，数据来自于多段线顶点坐标，但求多段线顶点坐标的函数返回的不是表，谢谢各位了

xshrimp · 发表于 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

革天明 · 发表于 2012-4-25 15:40:57

本帖最后由革天明于 2012-4-25 15:41 编辑

图片显示有点问题，点击一下可以放大而正常显示，谢谢各位对小弟的指点！

Andyhon · 发表于 2012-4-25 16:28:10

比较两线的长短 (Dist)
要用 Equal 取代 = (总得要容差)

革天明 · 发表于 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

革天明 · 发表于 2012-4-26 10:32:36

程序目前以“只有一个分界槽”来写的trim，后期可以将trim语句写在另外一个repeat中，

qjchen · 发表于 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兄都是好方法:)

也凑下热闹写一个递归的

(defun q:lst2(lst)
(q:lst1 (append lst (list (car lst) (cadr lst))))
)
(defun q:lst1(lst)
(cond ((not (caddr lst)) nil)
(T (cons (list (car lst) (cadr lst) (caddr lst)) (q:lst1 (cdr lst))))
)
)
(q:lst2 (list 1 2 3 4 5 6))

chlh_jd · 发表于 2012-4-26 14:32:03

这里也有个
http://www.theswamp.org/index.php?topic=34086.msg394120#msg394120

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

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

点评

本帖子中包含更多资源

本帖子中包含更多资源

评分