找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 4921|回复: 43

[飞鸟集] 自定义QSort函数, 欢迎前来踢馆!

[复制链接]

已领礼包: 8121个

财富等级: 富甲天下

发表于 2013-6-6 15:16:00 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

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

×
这个是我自己写的自定义qsort 函数,类似vl-sort,效率上似乎不差,编译后,比vl-sort 慢的不多。

Qsort1: 这个方式考虑了对某些极端情况有效,譬如,已经排好序(或者逆序)的,要比方式2快。
  1. ;;;=============================================================
  2. ;;;Highflybird's  Quick Sorting algorithm -- 1                  
  3. ;;;Considered this case: a sorted list.                        
  4. ;;;If the list is random,just a little slower than Quick Sort 2
  5. ;;;but the list is sorted,then is much faster than Quick Sort 2
  6. ;;;=============================================================
  7. (defun H:QSort1 (Lst / a k L R S)
  8.   (if (cddr lst)
  9.     (progn
  10.       (setq k (* (+ (car Lst) (last lst)) 0.5))                        ;the pivot,this is for the worst situation
  11.       (setq s lst)
  12.       (while s
  13.         (if (< (setq a (car S)) k)                              ;compare to the pivot
  14.           (setq L (cons a L))                                        ;put the less into the left list
  15.           (Setq R (cons a R))                                   ;put the greater into the right list
  16.         )
  17.         (setq S (cdr S))
  18.       )
  19.       (cond
  20.         ((null R) (H:QSort1 L))                                        ;the right is empty,the recurse the left
  21.         ((null L) (H:QSort1 R))                                        ;the Left is empty,the recurse the right
  22.         (T (append (H:QSort1 L) (H:QSort1 R)))                  ;otherwise,recurse both
  23.       )
  24.     )
  25.     (if (and (cdr lst) (> (car lst) (cadr lst)))                ;the length of list <= 2
  26.       (reverse lst)
  27.       lst
  28.     )
  29.   )
  30. )


Qsort2:平均性能是 O(log(N)),最坏情况是 O(N^2)
  1. ;;;=============================================================
  2. ;;;Highflybird's  Quick Sorting algorithm -- 2                  
  3. ;;;Based the Quick Sorting algorithm ,the worst O(N^2), the best
  4. ;;;is O(log(N)),average case performance is O(log(N))           
  5. ;;;=============================================================
  6. (defun H:QSort2 (Lst / a k L R S)
  7.   (if (cddr lst)
  8.     (progn
  9.       (setq k (car Lst))                                        ;the pivot
  10.       (setq S lst)
  11.       (while (setq S (cdr S))
  12.         (if (< (setq a (car S)) k)                                ;compare to the pivot
  13.           (setq L (cons a L))                                        ;put the less into the left list
  14.           (Setq R (cons a R))                                        ;put the greater into the right list
  15.         )
  16.       )
  17.       (cond
  18.         ((null R) (reverse (cons k (reverse (H:QSort2 L)))))        ;the right is empty,the recurse the left
  19.         ((null L) (cons k (H:QSort2 R)))                        ;the Left is empty,the recurse the right
  20.         (T (append (H:QSort2 L) (cons k (H:QSort2 R))))                ;otherwise,recurse both and add the pivot.
  21.       )
  22.     )
  23.     (if (and (cdr lst) (> (car lst) (cadr lst)))                ;the length of list <= 2
  24.       (reverse lst)
  25.       lst
  26.     )
  27.   )
  28. )

评分

参与人数 1D豆 +5 收起 理由
xshrimp + 5 很给力!经验;技术要点;资料分享奖!

查看全部评分

本帖被以下淘专辑推荐:

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

已领礼包: 8121个

财富等级: 富甲天下

 楼主| 发表于 2013-6-6 15:23:58 | 显示全部楼层
本帖最后由 Highflybird 于 2013-6-6 15:32 编辑

附上我的测试函数:
[pcode=lisp,true];;;----------------------------------------------------;
;;;测试用函数(benchMark function)                      ;
;;;----------------------------------------------------;
(defun MISC:Test (Times Expressions / s)
  (defun Benchmark (Func times / t0 t1 Speed Value FName)
    (setq t0 (getvar "TDUSRTIMER"))
    (repeat times
      (setq Value (eval Func))
    )
    (setq t1 (getvar "TDUSRTIMER"))
    ;(princ (list t1 t0))
    (setq t1 (* (- t1 t0) 86400000))
    (setq Speed (/ t1 times 1.0))
    (setq FName (vl-princ-to-string (car Func)))
    (list FName times t1 Speed Value)
  )
  (defun Princ-Column (str value / s)
    (setq s (vl-princ-to-string value))
    (princ s)
    (repeat (- (strlen str) (strlen s))
      (princ " ")
    )
  )
  (defun Print-Result (lst)
    (princ "\n")
    (princ-Column "Statement                         " (car lst))
    (princ-Column "Times    " (cadr lst))
    (princ-Column "Elapse(ms)    " (caddr lst))
    (princ-Column "Average(ms/time)" (cadddr lst))
  )

  (foreach Func Expressions
    (setq S (cons (BenchMark Func Times) S))
  )
  (princ "\nStatement                         Times    Elapse(ms)    Average(ms/time)")
  (princ "\n-------------------------------------------------------------------------")
  (setq s (vl-sort s (function (lambda (a b) (< (caddr a) (caddr b))))))
  (mapcar 'Print-Result s)
  (gc)
  s
)[/pcode]

大家可以构造一个随机的稍长的表,测试次数设置高一点,试试效果。

我提供一个构造长度为N 的随机排列表的函数:
[pcode=lisp,true]
;;;=============================================================
;;;A random List                                                
;;;a --maximum value,b --minimum value, n --length of the list  
;;;=============================================================
(defun GetRandList(a b n / str scr lst)
  (setq scr (vlax-create-object "ScriptControl"))  ;Create a script
  (if scr
    (progn
      (vlax-put scr 'Language "VBS")
      (setq str "Randomize\nFunction Rand(x,y)
                 \nRand=x+Rnd*(y-x)\nEnd Function")  ;for randomize some features
      (vlax-invoke Scr 'ExecuteStatement str)   ;Execute script
      (defun Rand (scr nMin nMax)           ;Rand function
        (vlax-invoke scr 'run "Rand" nMin nMax)
      )
    )
    (defun Rand (Option nMin nMax / seed)
      (setq seed (getvar "USERR4"))
      (if (= seed 0.)
        (setq seed (getvar "TDUSRTIMER")
       seed (- seed (fix seed))
       seed (rem (* seed 86400) 1)
        )
      )
      (setq seed (rem (+ (* seed 15625.7) 0.21137152) 1))
      (setvar "USERR4" seed)
      (+ nMin (* seed (- nMax nMin)))
    )
  )
  (repeat n
    (setq lst (cons (rand scr a b) lst))
  )
  (and scr (vlax-release-object scr))
  lst
)
[/pcode]

构造长度为N的有序表:
[pcode=lisp,true]
;;;=============================================================
;;;A sorted List (from 1 to N)                                 
;;;=============================================================
(defun SortedList(N  / i L)
  (setq i 1)
  (repeat N
    (setq l (cons i L))
    (setq i (1+ i))
  )
  (setq L (reverse L))
)[/pcode]

例如
  1. (setq lst (GetRandList 1 1000 1000) )
  2. (Misc:test  1000  '((H:qsort1 lst) (H:qsort2 lst)))


评分

参与人数 1D豆 +5 收起 理由
xshrimp + 5 很给力!经验;技术要点;资料分享奖!

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 51个

财富等级: 招财进宝

发表于 2013-6-6 15:26:59 | 显示全部楼层
大师作品,必须顶的。

飞鸟大师,能不能再给写几个选择排序,冒泡排序,二叉树排序,希尔排序什么的,给比较下。

点评

以后会陆续贴上,有的是国外的代码。  详情 回复 发表于 2013-6-6 15:30
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 8121个

财富等级: 富甲天下

 楼主| 发表于 2013-6-6 15:30:28 | 显示全部楼层
Lispboy 发表于 2013-6-6 15:26
大师作品,必须顶的。

飞鸟大师,能不能再给写几个选择排序,冒泡排序,二叉树排序,希尔排序什么的,给 ...

以后会陆续贴上,有的是国外的代码。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-6 17:35:48 | 显示全部楼层
貌视ALISP语言排序函数常常水土不服,即使编写正确无误。

点评

何种水土不服,请举例说明之。  详情 回复 发表于 2013-6-6 17:40
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 8121个

财富等级: 富甲天下

 楼主| 发表于 2013-6-6 17:40:29 | 显示全部楼层
crazylsp 发表于 2013-6-6 17:35
貌视ALISP语言排序函数常常水土不服,即使编写正确无误。

何种水土不服,请举例说明之。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-6 17:49:02 | 显示全部楼层
好,先说ALISP自带的Sort吧
当数组元素有小数时候,排序可重复;当无小数时候,排序无重复。
命令:(vl-sort '( 2 4 1 3 1 7 1 4 3 7 9 3 9 2 ) '< ) ->(1 2 3 4 7 9)
命令: (vl-sort '( 2.57 4.2 3 6 1.0 5 7 1.0 9.1 3 9.1 4.2 8 2.57 8 6) '< ) -> (1.0 1.0 2.57 2.57 3 4.2 4.2 5 6 7 8 9.1 9.1)
结果像3只有一个,但像1.0这些有小数的均留下来了, 是什么原因呢?请大师不吝赐教。

点评

为防止消重,可使用vl-sort-i函数!  详情 回复 发表于 2013-6-6 19:24
(vl-sort list comparison-function) 参数 list 任意表。 comparison-function 比较函数。它可以是任何一个这样的函数:接受如下两个参数,如果第一个参数按排序顺序在第二个元素之前,则返回 T 或非  详情 回复 发表于 2013-6-6 17:52
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 8121个

财富等级: 富甲天下

 楼主| 发表于 2013-6-6 17:52:17 | 显示全部楼层
本帖最后由 Highflybird 于 2013-6-6 17:58 编辑
crazylsp 发表于 2013-6-6 17:49
好,先说ALISP自带的Sort吧
当数组元素有小数时候,排序可重复;当无小数时候,排序无重复。
命令vl-s ...

(vl-sort  list comparison-function)
参数

list

任意表。

comparison-function

比较函数。它可以是任何一个这样的函数:接受如下两个参数,如果第一个参数按排序顺序在第二个元素之前,则返回 T 或非 nil 值。comparison-function 的值可以采用如下格式:

符号 (函数名)  
'(LAMBDA (A1 A2) ...)
(FUNCTION (LAMBDA (A1 A2) ...))
返回值

表,其中包含 list 中的元素,这些元素按照 comparison-function 中指定的顺序排列。表中可能删除了重复的元素。

vl-sort函数的确可能会删除重复的元素。这点特别要注意。 如果你不希望消重的话,就不应该用vl-sort!
但我这个函数不会。

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-6 18:03:49 | 显示全部楼层
本帖最后由 crazylsp 于 2013-6-6 18:18 编辑
但我这个函数不会。

哈哈大师太谦虚了。再说一下自定义排序函数:
再帮我检查一下下面的点坐标排序程序(没按排序算法做的),谢谢,从测试的结果看没有问题,但为什么用到按顺序检查文字会出现会出现错位的现象。不过比vl-sort好一点,没有太离谱。
  1. ;;X方向点坐标排序
  2. (defun XX ( lst /)
  3.    (setq   ll   (length lst)  
  4.            amin (apply 'min (mapcar '( lambda (x) (car x) ) lst ) )
  5.            aa   (assoc amin lst)
  6.            lst2 (list aa)
  7.            lst  (vl-remove aa lst)
  8.    )
  9.    (repeat (- ll 1)   
  10.       (setq amin (apply 'min (mapcar '(lambda (x) (car x) ) lst ) )
  11.             aa   (assoc amin lst)
  12.             lst2 (append lst2 (list aa) )  
  13.             lst  (vl-remove aa lst)
  14.       )
  15.    )
  16.    (vl-remove nil lst2)
  17. )
  18. ;;Y方向点坐标排序
  19. (defun YY ( lst /)
  20.    (setq   lst  ( mapcar '( lambda (x) (reverse x) ) lst )
  21.            ll   (length lst)  
  22.            amin (apply 'min (mapcar '( lambda (x) (car x) ) lst ) )
  23.            aa   (assoc amin lst)
  24.            lst2 (list aa)
  25.            lst  (vl-remove aa lst)
  26.    )
  27.    (repeat (- ll 1)   
  28.       (setq amin (apply 'min (mapcar '(lambda (x) (car x) ) lst ) )
  29.             aa   (assoc amin lst)
  30.             lst2 (append lst2 (list aa) )  
  31.             lst  (vl-remove aa lst)
  32.       )
  33.    )
  34.    (setq   lst2 ( mapcar '( lambda (x) (reverse x) ) lst2 ))
  35.    (vl-remove nil lst2)
  36. )
  37. ;;点的坐标排序
  38. (defun XY ( lst /)
  39.    (yy(xx lst))
  40. )
  41. ;;x方向复核文字
  42. (defun c:tt()
  43.    (setq ss (ssget '((0 . "*text")) ) ssl(sslength ss) i 0 ptlst'())
  44.    (repeat ssl  
  45.       (setq pt(cdr(assoc 10 (entget (ssname ss i)))))
  46.       (setq ptlst(cons pt ptlst))
  47.       (setq i(1+ i))
  48.    )
  49.    (foreach p (xx ptlst)
  50.        (if (getpoint p "<<")
  51.          (command "zoom" "non"p pause )
  52.         ;(command "-pan" "non"(getvar "viewctr") "non"p )
  53.        )
  54.    )
  55. )
  56. ;;Y方向复核文字
  57. (defun c:ttt()
  58.    (setq ss (ssget '((0 . "*text")) ) ssl(sslength ss) i 0 ptlst'())
  59.    (repeat ssl  
  60.       (setq pt(cdr(assoc 10 (entget (ssname ss i)))))
  61.       (setq ptlst(cons pt ptlst))
  62.       (setq i(1+ i))
  63.    )
  64.    (foreach p (yy ptlst)
  65.        (if (getpoint p "<<")
  66.          (command "zoom" "non"p pause )
  67.         ;(command "-pan" "non"(getvar "viewctr") "non"p )
  68.        )
  69.    )
  70. )




测试文件.rar

286.01 KB, 下载次数: 5, 下载积分: D豆 -1 , 活跃度 1

点评

最好附上一个dwg 用以检测。  详情 回复 发表于 2013-6-6 18:06
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 8121个

财富等级: 富甲天下

 楼主| 发表于 2013-6-6 18:06:29 | 显示全部楼层
crazylsp 发表于 2013-6-6 18:03
再帮我检查一下下面的点坐标排序程序(没按排序算法做的),从测试的结果看没有问题,但为什么用到按顺序检查 ...

最好附上一个dwg 用以检测。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 6530个

财富等级: 富甲天下

发表于 2013-6-6 18:34:19 | 显示全部楼层
本帖最后由 ll_j 于 2013-6-6 18:38 编辑

vl-sort似乎只在对整数排序的时候会删除重复,在其它情况下(比如点表)好像都是正确的,如果不考虑出现一些特殊情况,还是可以放心使用的。

命令: (vl-sort '(1.0 2 1 3 2 3.0 5 3.0 1) '<)
(1.0 1 2 3 3.0 3.0 5)

毕竟整数在运算中使用到排序的情况不多。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 8121个

财富等级: 富甲天下

 楼主| 发表于 2013-6-6 18:42:52 | 显示全部楼层
crazylsp不妨试下我的排序程序。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 344个

财富等级: 日进斗金

发表于 2013-6-6 19:24:14 来自手机 | 显示全部楼层
crazylsp 发表于 2013-6-6 17:49
好,先说ALISP自带的Sort吧
当数组元素有小数时候,排序可重复;当无小数时候,排序无重复。
命令vl-s ...

为防止消重,可使用vl-sort-i函数!

评分

参与人数 1D豆 +5 收起 理由
wowan1314 + 5 正解!!!

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 604个

财富等级: 财运亨通

发表于 2013-6-6 20:36:03 | 显示全部楼层
大师又出精品了,等有空了,下载来好好学习!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-6 22:00:02 | 显示全部楼层
{:soso_e100:}
毕竟整数在运算中使用到排序的情况不多。

确实是这样。整数的重复排序我已做成,不过感觉对画图确实没什么用途

  1. crazylsp不妨试下我的排序程序。
复制代码
好的,我选试下大师的宝贝,有问题我们又来研究。

为防止消重,可使用vl-sort-i函数!

哦,原来可以这样

点评

其实,做个实数的排序就够了,排整数的时候,可以先FLOAT他们,排序完在FIX。  详情 回复 发表于 2013-6-6 22:19
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-3-29 01:31 , Processed in 0.373935 second(s), 63 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

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