1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
|
;;;; sort.jl -- Sorting functions
;;; Copyright (C) 1998 John Harper <john@dcs.warwick.ac.uk>
;;; $Id$
;;; This file is part of Jade.
;;; Jade is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
;;; Jade is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with Jade; see the file COPYING. If not, write to
;;; the Free Software Foundation, 51 Franklin Street, Fifth Floor,
;;; Boston, MA 02110-1301 USA
(declare (in-module rep.data)
(unsafe-for-call/cc))
(open-structures '(rep.lang.math))
;;;###autoload
(defun sort (lst #!optional pred)
"Sort LST destructively, but stably, returning the sorted list.
If PRED is defined it is used to compare two objects, it should return t
when the first is `less' than the second. By default the standard less-than
function (`<') is used.
The fact that the sort is stable means that sort keys which are equal will
preserve their original position in relation to each other."
(let
((len (length lst)))
(if (< len 2)
lst
;; default to sorting smaller to greater
(unless pred (setq pred <))
(let
((mid (nthcdr (1- (quotient len 2)) lst)))
(setq mid (prog1
(cdr mid)
(rplacd mid nil)))
;; Now we have two separate lists, LST and MID; sort them..
(setq lst (sort lst pred)
mid (sort mid pred))
;; ..then merge them back together
(let
((out-head nil) ;Start of the list being built
(out nil) ;Cell whose cdr is next link
tem)
;; While both lists have elements compare them
(while (and lst mid)
(setq tem (if (funcall pred (car mid) (car lst))
(prog1
mid
(setq mid (cdr mid)))
(prog1
lst
(setq lst (cdr lst)))))
(if out
(progn
(rplacd out tem)
(setq out tem))
(setq out-head tem
out tem)))
;; If either has elements left just append them
(when (or lst mid)
(if out
(rplacd out (or lst mid))
(setq out-head (or lst mid))))
out-head)))))
|
