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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
;;;
;;; This code is in the public domain.
;;; Updated: 11 June 1991
;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
;;; Updated: 19 June 1995
;;; (sorted? sequence less?)
;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;; such that for all 1 <= i <= m,
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
(define (sort:sorted? seq less?)
(cond
((null? seq)
#t)
((vector? seq)
(let ((n (vector-length seq)))
(if (<= n 1)
#t
(do ((i 1 (+ i 1)))
((or (= i n)
(less? (vector-ref seq i)
(vector-ref seq (- i 1))))
(= i n)) )) ))
(else
(let loop ((last (car seq)) (next (cdr seq)))
(or (null? next)
(and (not (less? (car next) last))
(loop (car next) (cdr next)) )) )) ))
;;; (merge a b less?)
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
;;; and returns a new list in which the elements of a and b have been stably
;;; interleaved so that (sorted? (merge a b less?) less?).
;;; Note: this does _not_ accept vectors. See below.
(define (sort:merge a b less?)
(cond
((null? a) b)
((null? b) a)
(else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? y x)
(if (null? b)
(cons y (cons x a))
(cons y (loop x a (car b) (cdr b)) ))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (cdr a) y b)) )) )) ))
;;; (merge! a b less?)
;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both.
;;; Note: this does _not_ accept vectors.
(define (sort:merge! a b less?)
(define (loop r a b)
(if (less? (car b) (car a))
(begin
(set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)) ))
;; (car a) <= (car b)
(begin
(set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b)) )) )
(cond
((null? a) b)
((null? b) a)
((less? (car b) (car a))
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)))
b)
(else ; (car a) <= (car b)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b))
a)))
;;; (sort! sequence less?)
;;; sorts the list or vector sequence destructively. It uses a version
;;; of merge-sort invented, to the best of my knowledge, by David H. D.
;;; Warren, and first used in the DEC-10 Prolog system. R. A. O'Keefe
;;; adapted it to work destructively in Scheme.
(define (sort:sort! seq less?)
(define (step n)
(cond
((> n 2)
(let* ((j (quotient n 2))
(a (step j))
(k (- n j))
(b (step k)))
(sort:merge! a b less?)))
((= n 2)
(let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(if (less? y x) (begin
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1)
(let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else
'()) ))
(if (vector? seq)
(let ((n (vector-length seq))
(vec seq))
(set! seq (vector->list seq))
(do ((p (step n) (cdr p))
(i 0 (+ i 1)))
((null? p) vec)
(vector-set! vec i (car p)) ))
;; otherwise, assume it is a list
(step (length seq)) ))
;;; (sort sequence less?)
;;; sorts a vector or list non-destructively. It does this by sorting a
;;; copy of the sequence. My understanding is that the Standard says
;;; that the result of append is always "newly allocated" except for
;;; sharing structure with "the last argument", so (append x '()) ought
;;; to be a standard way of copying a list x.
(define (sort:sort seq less?)
(if (vector? seq)
(list->vector (sort:sort! (vector->list seq) less?))
(sort:sort! (append seq '()) less?)))
;;; eof
(define sorted? sort:sorted?)
(define merge sort:merge)
(define merge! sort:merge!)
(define sort sort:sort)
(define sort! sort:sort!)
|
