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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
|
;;; "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
;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
;;; jaffer: 2006-10-08:
;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
;;; jaffer: 2006-11-05:
;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
;;; per element.
;;; jaffer: 2007-01-29: Final SRFI-95.
;;; Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
;; ChangeLog
;;
;; 2007-07-13 yamaken - Imported from SLIB CVS HEAD (revision 1.14)
;; http://cvs.savannah.gnu.org/viewvc/*checkout*/slib/slib/sort.scm?revision=1.14
;; and adapted to SigScheme
;;(require 'array)
;; For SigScheme
(define array?
(if (symbol-bound? 'array?)
(symbol-value 'array)
(lambda (x) #f)))
(define identity
(if (symbol-bound? 'identity)
(symbol-value 'identity)
(lambda (x) x)))
;;; (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 (sorted? seq less? . opt-key)
(define key (if (null? opt-key) identity (car opt-key)))
(cond ((null? seq) #t)
((array? seq)
(let ((dimax (+ -1 (car (array-dimensions seq)))))
(or (<= dimax 1)
(let loop ((idx (+ -1 dimax))
(last (key (array-ref seq dimax))))
(or (negative? idx)
(let ((nxt (key (array-ref seq idx))))
(and (less? nxt last)
(loop (+ -1 idx) nxt))))))))
((null? (cdr seq)) #t)
(else
(let loop ((last (key (car seq)))
(next (cdr seq)))
(or (null? next)
(let ((nxt (key (car next))))
(and (not (less? nxt last))
(loop nxt (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 arrays. See below.
;@
(define (merge a b less? . opt-key)
(define key (if (null? opt-key) identity (car opt-key)))
(cond ((null? a) b)
((null? b) a)
(else
(let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
(y (car b)) (ky (key (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? ky kx)
(if (null? b)
(cons y (cons x a))
(cons y (loop x kx a (car b) (key (car b)) (cdr b))))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
(define (sort:merge! a b less? key)
(define (loop r a kcara b kcarb)
(cond ((less? kcarb kcara)
(set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b)))))
(else ; (car a) <= (car b)
(set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb)))))
(cond ((null? a) b)
((null? b) a)
(else
(let ((kcara (key (car a)))
(kcarb (key (car b))))
(cond
((less? kcarb kcara)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a kcara (cdr b) (key (cadr b))))
b)
(else ; (car a) <= (car b)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) (key (cadr a)) b kcarb))
a))))))
;;; 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 arrays.
;@
(define (merge! a b less? . opt-key)
(sort:merge! a b less? (if (null? opt-key) identity (car opt-key))))
(define (sort:sort-list! seq less? key)
(define keyer (if key car identity))
(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? keyer)))
((= n 2) (let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(cond ((less? (keyer y) (keyer x))
(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 '())))
(define (key-wrap! lst)
(cond ((null? lst))
(else (set-car! lst (cons (key (car lst)) (car lst)))
(key-wrap! (cdr lst)))))
(define (key-unwrap! lst)
(cond ((null? lst))
(else (set-car! lst (cdar lst))
(key-unwrap! (cdr lst)))))
(cond (key
(key-wrap! seq)
(set! seq (step (length seq)))
(key-unwrap! seq)
seq)
(else
(step (length seq)))))
(define (rank-1-array->list array)
(define dimensions (array-dimensions array))
(do ((idx (+ -1 (car dimensions)) (+ -1 idx))
(lst '() (cons (array-ref array idx) lst)))
((< idx 0) lst)))
;;; (sort! sequence less?)
;;; sorts the list, array, or string 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.
;;; A. Jaffer modified to always return the original list.
;@
(define (sort! seq less? . opt-key)
(define key (if (null? opt-key) #f (car opt-key)))
(cond ((array? seq)
(let ((dims (array-dimensions seq)))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted))
(i 0 (+ i 1)))
((null? sorted) seq)
(array-set! seq (car sorted) i))))
(else ; otherwise, assume it is a list
(let ((ret (sort:sort-list! seq less? key)))
(if (not (eq? ret seq))
(do ((crt ret (cdr crt)))
((eq? (cdr crt) seq)
(set-cdr! crt ret)
(let ((scar (car seq)) (scdr (cdr seq)))
(set-car! seq (car ret)) (set-cdr! seq (cdr ret))
(set-car! ret scar) (set-cdr! ret scdr)))))
seq))))
;;; (sort sequence less?)
;;; sorts a array, string, 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 seq less? . opt-key)
(define key (if (null? opt-key) #f (car opt-key)))
(cond ((array? seq)
(let ((dims (array-dimensions seq)))
(define newra (apply make-array seq dims))
(do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
(cdr sorted))
(i 0 (+ i 1)))
((null? sorted) newra)
(array-set! newra (car sorted) i))))
(else (sort:sort-list! (append seq '()) less? key))))
|
