|
| 1 | +;;; SRFI 95 |
| 2 | +;;; Sorting and Merging |
| 3 | +;;; |
| 4 | +;;; Sorting and merging are useful operations deserving a common API. This SRFI |
| 5 | +;;; defines simple functions supporting sorting and merging. The sort procedures |
| 6 | +;;; operate on lists and arrays, which includes vectors. The merge procedures |
| 7 | +;;; operate on lists. |
| 8 | +;;; |
| 9 | +;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort! |
| 10 | +;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) |
| 11 | +;;; |
| 12 | +;;; Made an R7RS library by Taylan Ulrich Bayırlı/Kammer, Copyright (C) 2014. |
| 13 | +;;; |
| 14 | +;;; Copyright © 2006 Aubrey Jaffer. All Rights Reserved. |
| 15 | +;;; |
| 16 | +;;; Permission is hereby granted, free of charge, to any person obtaining a copy |
| 17 | +;;; of this software and associated documentation files (the "Software"), to |
| 18 | +;;; deal in the Software without restriction, including without limitation the |
| 19 | +;;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or |
| 20 | +;;; sell copies of the Software, and to permit persons to whom the Software is |
| 21 | +;;; furnished to do so, subject to the following conditions: |
| 22 | +;;; |
| 23 | +;;; The above copyright notice and this permission notice shall be included in |
| 24 | +;;; all copies or substantial portions of the Software. |
| 25 | +;;; |
| 26 | +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR |
| 27 | +;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, |
| 28 | +;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE |
| 29 | +;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER |
| 30 | +;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING |
| 31 | +;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS |
| 32 | +;;; IN THE SOFTWARE. |
| 33 | +;;; |
| 34 | +;;; Updated: 11 June 1991 |
| 35 | +;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991 |
| 36 | +;;; Updated: 19 June 1995 |
| 37 | +;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09 |
| 38 | +;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04 |
| 39 | +;;; jaffer: 2006-10-08: |
| 40 | +;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument. |
| 41 | +;;; jaffer: 2006-11-05: |
| 42 | +;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once |
| 43 | +;;; per element. |
| 44 | +;;; |
| 45 | +;;; Adaptation to LispKit |
| 46 | +;;; Copyright © 2018 Matthias Zenger. All rights reserved. |
| 47 | + |
| 48 | +(define-library (srfi 95) |
| 49 | + |
| 50 | + (export sorted? |
| 51 | + merge |
| 52 | + merge! |
| 53 | + sort |
| 54 | + sort!) |
| 55 | + |
| 56 | + (import (except (scheme base) equal?) |
| 57 | + (srfi 63)) |
| 58 | + |
| 59 | + (begin |
| 60 | + |
| 61 | + ;; (sorted? sequence less?) |
| 62 | + ;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) |
| 63 | + ;; such that for all 1 <= i <= m, |
| 64 | + ;; (not (less? (list-ref list i) (list-ref list (- i 1)))). |
| 65 | + (define (sorted? seq less? . opt-key) |
| 66 | + (define key (if (null? opt-key) values (car opt-key))) |
| 67 | + (cond ((null? seq) #t) |
| 68 | + ((array? seq) |
| 69 | + (let ((dimax (+ -1 (car (array-dimensions seq))))) |
| 70 | + (or (<= dimax 1) |
| 71 | + (let loop ((idx (+ -1 dimax)) |
| 72 | + (last (key (array-ref seq dimax)))) |
| 73 | + (or (negative? idx) |
| 74 | + (let ((nxt (key (array-ref seq idx)))) |
| 75 | + (and (less? nxt last) |
| 76 | + (loop (+ -1 idx) nxt)))))))) |
| 77 | + ((null? (cdr seq)) #t) |
| 78 | + (else |
| 79 | + (let loop ((last (key (car seq))) |
| 80 | + (next (cdr seq))) |
| 81 | + (or (null? next) |
| 82 | + (let ((nxt (key (car next)))) |
| 83 | + (and (not (less? nxt last)) |
| 84 | + (loop nxt (cdr next))))))))) |
| 85 | + |
| 86 | + ;; (merge a b less?) |
| 87 | + ;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?) |
| 88 | + ;; and returns a new list in which the elements of a and b have been stably |
| 89 | + ;; interleaved so that (sorted? (merge a b less?) less?). |
| 90 | + ;; Note: this does _not_ accept arrays. See below. |
| 91 | + (define (merge a b less? . opt-key) |
| 92 | + (define key (if (null? opt-key) values (car opt-key))) |
| 93 | + (cond ((null? a) b) |
| 94 | + ((null? b) a) |
| 95 | + (else |
| 96 | + (let loop ((x (car a)) (kx (key (car a))) (a (cdr a)) |
| 97 | + (y (car b)) (ky (key (car b))) (b (cdr b))) |
| 98 | + ;; The loop handles the merging of non-empty lists. It has |
| 99 | + ;; been written this way to save testing and car/cdring. |
| 100 | + (if (less? ky kx) |
| 101 | + (if (null? b) |
| 102 | + (cons y (cons x a)) |
| 103 | + (cons y (loop x kx a (car b) (key (car b)) (cdr b)))) |
| 104 | + ;; x <= y |
| 105 | + (if (null? a) |
| 106 | + (cons x (cons y b)) |
| 107 | + (cons x (loop (car a) (key (car a)) (cdr a) y ky b)))))))) |
| 108 | + |
| 109 | + (define (sort:merge! a b less? key) |
| 110 | + (define (loop r a kcara b kcarb) |
| 111 | + (cond ((less? kcarb kcara) |
| 112 | + (set-cdr! r b) |
| 113 | + (if (null? (cdr b)) |
| 114 | + (set-cdr! b a) |
| 115 | + (loop b a kcara (cdr b) (key (cadr b))))) |
| 116 | + (else ; (car a) <= (car b) |
| 117 | + (set-cdr! r a) |
| 118 | + (if (null? (cdr a)) |
| 119 | + (set-cdr! a b) |
| 120 | + (loop a (cdr a) (key (cadr a)) b kcarb))))) |
| 121 | + (cond ((null? a) b) |
| 122 | + ((null? b) a) |
| 123 | + (else |
| 124 | + (let ((kcara (key (car a))) |
| 125 | + (kcarb (key (car b)))) |
| 126 | + (cond |
| 127 | + ((less? kcarb kcara) |
| 128 | + (if (null? (cdr b)) |
| 129 | + (set-cdr! b a) |
| 130 | + (loop b a kcara (cdr b) (key (cadr b)))) |
| 131 | + b) |
| 132 | + (else ; (car a) <= (car b) |
| 133 | + (if (null? (cdr a)) |
| 134 | + (set-cdr! a b) |
| 135 | + (loop a (cdr a) (key (cadr a)) b kcarb)) |
| 136 | + a)))))) |
| 137 | + |
| 138 | + ;; takes two sorted lists a and b and smashes their cdr fields to form a |
| 139 | + ;; single sorted list including the elements of both. |
| 140 | + ;; Note: this does _not_ accept arrays. |
| 141 | + (define (merge! a b less? . opt-key) |
| 142 | + (sort:merge! a b less? (if (null? opt-key) values (car opt-key)))) |
| 143 | + |
| 144 | + (define (sort:sort-list! seq less? key) |
| 145 | + (define keyer (if key car values)) |
| 146 | + (define (step n) |
| 147 | + (cond ((> n 2) (let* ((j (quotient n 2)) |
| 148 | + (a (step j)) |
| 149 | + (k (- n j)) |
| 150 | + (b (step k))) |
| 151 | + (sort:merge! a b less? keyer))) |
| 152 | + ((= n 2) (let ((x (car seq)) |
| 153 | + (y (cadr seq)) |
| 154 | + (p seq)) |
| 155 | + (set! seq (cddr seq)) |
| 156 | + (cond ((less? (keyer y) (keyer x)) |
| 157 | + (set-car! p y) |
| 158 | + (set-car! (cdr p) x))) |
| 159 | + (set-cdr! (cdr p) '()) |
| 160 | + p)) |
| 161 | + ((= n 1) (let ((p seq)) |
| 162 | + (set! seq (cdr seq)) |
| 163 | + (set-cdr! p '()) |
| 164 | + p)) |
| 165 | + (else '()))) |
| 166 | + (define (key-wrap! lst) |
| 167 | + (cond ((null? lst)) |
| 168 | + (else (set-car! lst (cons (key (car lst)) (car lst))) |
| 169 | + (key-wrap! (cdr lst))))) |
| 170 | + (define (key-unwrap! lst) |
| 171 | + (cond ((null? lst)) |
| 172 | + (else (set-car! lst (cdar lst)) |
| 173 | + (key-unwrap! (cdr lst))))) |
| 174 | + (cond (key |
| 175 | + (key-wrap! seq) |
| 176 | + (set! seq (step (length seq))) |
| 177 | + (key-unwrap! seq) |
| 178 | + seq) |
| 179 | + (else |
| 180 | + (step (length seq))))) |
| 181 | + |
| 182 | + (define (rank-1-array->list array) |
| 183 | + (define dimensions (array-dimensions array)) |
| 184 | + (do ((idx (+ -1 (car dimensions)) (+ -1 idx)) |
| 185 | + (lst '() (cons (array-ref array idx) lst))) |
| 186 | + ((< idx 0) lst))) |
| 187 | + |
| 188 | + ;; (sort! sequence less?) |
| 189 | + ;; sorts the list, array, or string sequence destructively. It uses |
| 190 | + ;; a version of merge-sort invented, to the best of my knowledge, by |
| 191 | + ;; David H. D. Warren, and first used in the DEC-10 Prolog system. |
| 192 | + ;; R. A. O'Keefe adapted it to work destructively in Scheme. |
| 193 | + ;; A. Jaffer modified to always return the original list. |
| 194 | + (define (sort! seq less? . opt-key) |
| 195 | + (define key (if (null? opt-key) #f (car opt-key))) |
| 196 | + (cond ((array? seq) |
| 197 | + (let ((dims (array-dimensions seq))) |
| 198 | + (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) |
| 199 | + (cdr sorted)) |
| 200 | + (i 0 (+ i 1))) |
| 201 | + ((null? sorted) seq) |
| 202 | + (array-set! seq (car sorted) i)))) |
| 203 | + (else ; otherwise, assume it is a list |
| 204 | + (let ((ret (sort:sort-list! seq less? key))) |
| 205 | + (if (not (eq? ret seq)) |
| 206 | + (do ((crt ret (cdr crt))) |
| 207 | + ((eq? (cdr crt) seq) |
| 208 | + (set-cdr! crt ret) |
| 209 | + (let ((scar (car seq)) (scdr (cdr seq))) |
| 210 | + (set-car! seq (car ret)) (set-cdr! seq (cdr ret)) |
| 211 | + (set-car! ret scar) (set-cdr! ret scdr))))) |
| 212 | + seq)))) |
| 213 | + |
| 214 | + ;; (sort sequence less?) |
| 215 | + ;; sorts a array, string, or list non-destructively. It does this |
| 216 | + ;; by sorting a copy of the sequence. My understanding is that the |
| 217 | + ;; Standard says that the result of append is always "newly |
| 218 | + ;; allocated" except for sharing structure with "the last argument", |
| 219 | + ;; so (append x '()) ought to be a standard way of copying a list x. |
| 220 | + (define (sort seq less? . opt-key) |
| 221 | + (define key (if (null? opt-key) #f (car opt-key))) |
| 222 | + (cond ((array? seq) |
| 223 | + (let ((dims (array-dimensions seq))) |
| 224 | + (define newra (apply make-array seq dims)) |
| 225 | + (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key) |
| 226 | + (cdr sorted)) |
| 227 | + (i 0 (+ i 1))) |
| 228 | + ((null? sorted) newra) |
| 229 | + (array-set! newra (car sorted) i)))) |
| 230 | + (else (sort:sort-list! (append seq '()) less? key)))) |
| 231 | + ) |
| 232 | +) |
| 233 | + |
0 commit comments