Changeset 2305 in project


Ignore:
Timestamp:
11/08/06 06:44:49 (15 years ago)
Author:
felix winkelmann
Message:

srfi-95 update and antispam

Files:
2 deleted
3 edited

Legend:

Unmodified
Added
Removed
  • srfi-95/srfi-95.scm

    r2176 r2305  
    33;;;
    44;;; This code is in the public domain.
    5 ;;; Trivially modified for Chicken Scheme by John Cowan.
    65
    76;;; Updated: 11 June 1991
     
    1211;;; jaffer: 2006-10-08:
    1312;;; (sort, sort!, sorted?, merge, merge!): Added optional KEY argument.
     13;;; jaffer: 2006-11-05:
     14;;; (sorted?, merge, merge!, sort, sort!): Call KEY arg at most once
     15;;; per element.
     16;;; Trivially modified for Chicken Scheme by John Cowan.
    1417
    1518(use array-lib)
    1619(declare (export sort sort! sorted? merge merge!))
    17 
    18 (define (rank-1-array->list array)
    19   (define dimensions (array-dimensions array))
    20   (do ((idx (+ -1 (car dimensions)) (+ -1 idx))
    21        (lst '() (cons (array-ref array idx) lst)))
    22       ((< idx 0) lst)))
    23 
    24 (define (sort:make-predicate caller less? opt-key)
    25   (case (length opt-key)
    26     ((0) less?)
    27     ((1) (let ((key (car opt-key)))
    28            (lambda (a b) (less? (key a) (key b)))))
    29     (else (slib:error caller 'too-many-args (cdr opt-key)))))
    3020
    3121;;; (sorted? sequence less?)
     
    3525;@
    3626(define (sorted? seq less? . opt-key)
    37   (set! less? (sort:make-predicate 'sorted? less? opt-key))
     27  (define key (if (null? opt-key) identity (car opt-key)))
    3828  (cond ((null? seq) #t)
    39         ((array? seq)
    40          (let ((dims (array-dimensions seq)))
    41            (define dimax (+ -1 (car dims)))
    42            (or (<= dimax 0)
    43                (do ((i 1 (+ i 1)))
    44                    ((or (= i dimax)
    45                         (less? (array-ref seq i)
    46                                (array-ref seq (- i 1))))
    47                     (= i dimax))))))
    48         (else
    49          (let loop ((last (car seq)) (next (cdr seq)))
    50            (or (null? next)
    51                (and (not (less? (car next) last))
    52                     (loop (car next) (cdr next))))))))
     29        ((array? seq)
     30         (let ((dimax (+ -1 (car (array-dimensions seq)))))
     31           (or (<= dimax 1)
     32               (let loop ((idx (+ -1 dimax))
     33                          (last (key (array-ref seq dimax))))
     34                 (or (negative? idx)
     35                     (let ((nxt (key (array-ref seq idx))))
     36                       (and (less? nxt last)
     37                            (loop (+ -1 idx) nxt))))))))
     38        ((null? (cdr seq)) #t)
     39        (else
     40         (let loop ((last (key (car seq)))
     41                    (next (cdr seq)))
     42           (or (null? next)
     43               (let ((nxt (key (car next))))
     44                 (and (not (less? nxt last))
     45                      (loop nxt (cdr next)))))))))
    5346
    5447;;; (merge a b less?)
     
    5952;@
    6053(define (merge a b less? . opt-key)
    61   (set! less? (sort:make-predicate 'merge less? opt-key))
     54  (define key (if (null? opt-key) identity (car opt-key)))
    6255  (cond ((null? a) b)
    63         ((null? b) a)
    64         (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
    65                 ;; The loop handles the merging of non-empty lists.  It has
    66                 ;; been written this way to save testing and car/cdring.
    67                 (if (less? y x)
    68                     (if (null? b)
    69                         (cons y (cons x a))
    70                         (cons y (loop x a (car b) (cdr b))))
    71                     ;; x <= y
    72                     (if (null? a)
    73                         (cons x (cons y b))
    74                         (cons x (loop (car a) (cdr a) y b))))))))
     56        ((null? b) a)
     57        (else
     58         (let loop ((x (car a)) (kx (key (car a))) (a (cdr a))
     59                    (y (car b)) (ky (key (car b))) (b (cdr b)))
     60           ;; The loop handles the merging of non-empty lists.  It has
     61           ;; been written this way to save testing and car/cdring.
     62           (if (less? ky kx)
     63               (if (null? b)
     64                   (cons y (cons x a))
     65                   (cons y (loop x kx a (car b) (key (car b)) (cdr b))))
     66               ;; x <= y
     67               (if (null? a)
     68                   (cons x (cons y b))
     69                   (cons x (loop (car a) (key (car a)) (cdr a) y ky b))))))))
    7570
    76 (define (sort:merge! a b less?)
    77   (define (loop r a b)
    78     (if (less? (car b) (car a))
    79         (begin
    80           (set-cdr! r b)
    81           (if (null? (cdr b))
    82               (set-cdr! b a)
    83               (loop b a (cdr b))))
    84         ;; (car a) <= (car b)
    85         (begin
    86           (set-cdr! r a)
    87           (if (null? (cdr a))
    88               (set-cdr! a b)
    89               (loop a (cdr a) b)))))
     71(define (sort:merge! a b less? key)
     72  (define (loop r a kcara b kcarb)
     73    (cond ((less? kcarb kcara)
     74           (set-cdr! r b)
     75           (if (null? (cdr b))
     76               (set-cdr! b a)
     77               (loop b a kcara (cdr b) (key (cadr b)))))
     78          (else                         ; (car a) <= (car b)
     79           (set-cdr! r a)
     80           (if (null? (cdr a))
     81               (set-cdr! a b)
     82               (loop a (cdr a) (key (cadr a)) b kcarb)))))
    9083  (cond ((null? a) b)
    91         ((null? b) a)
    92         ((less? (car b) (car a))
    93          (if (null? (cdr b))
    94              (set-cdr! b a)
    95              (loop b a (cdr b)))
    96          b)
    97         (else                           ; (car a) <= (car b)
    98          (if (null? (cdr a))
    99              (set-cdr! a b)
    100              (loop a (cdr a) b))
    101          a)))
     84        ((null? b) a)
     85        (else
     86         (let ((kcara (key (car a)))
     87               (kcarb (key (car b))))
     88           (cond
     89            ((less? kcarb kcara)
     90             (if (null? (cdr b))
     91                 (set-cdr! b a)
     92                 (loop b a kcara (cdr b) (key (cadr b))))
     93             b)
     94            (else                       ; (car a) <= (car b)
     95             (if (null? (cdr a))
     96                 (set-cdr! a b)
     97                 (loop a (cdr a) (key (cadr a)) b kcarb))
     98             a))))))
    10299
    103 ;;; (merge! a b less?)
    104100;;; takes two sorted lists a and b and smashes their cdr fields to form a
    105101;;; single sorted list including the elements of both.
     
    107103;@
    108104(define (merge! a b less? . opt-key)
    109   (sort:merge! a b (sort:make-predicate 'merge! less? opt-key)))
     105  (sort:merge! a b less? (if (null? opt-key) identity (car opt-key))))
    110106
    111 (define (sort:sort! seq less?)
     107(define (sort:sort-list! seq less? key)
    112108  (define (step n)
    113     (cond ((> n 2)
    114            (let* ((j (quotient n 2))
    115                   (a (step j))
    116                   (k (- n j))
    117                   (b (step k)))
    118              (sort:merge! a b less?)))
    119           ((= n 2)
    120            (let ((x (car seq))
    121                  (y (cadr seq))
    122                  (p seq))
    123              (set! seq (cddr seq))
    124              (cond ((less? y x)
    125                     (set-car! p y)
    126                     (set-car! (cdr p) x)))
    127              (set-cdr! (cdr p) '())
    128              p))
    129           ((= n 1)
    130            (let ((p seq))
    131              (set! seq (cdr seq))
    132              (set-cdr! p '())
    133              p))
    134           (else
    135            '())))
    136   (cond ((array? seq)
    137          (let ((dims (array-dimensions seq))
    138                (vec seq))
    139            (set! seq (rank-1-array->list seq))
    140            (do ((p (step (car dims)) (cdr p))
    141                 (i 0 (+ i 1)))
    142                ((null? p) vec)
    143              (array-set! vec (car p) i))))
    144         (else ;; otherwise, assume it is a list
    145          (step (length seq)))))
     109    (cond ((> n 2) (let* ((j (quotient n 2))
     110                          (a (step j))
     111                          (k (- n j))
     112                          (b (step k)))
     113                     (sort:merge! a b less? car)))
     114          ((= n 2) (let ((x (car seq))
     115                         (y (cadr seq))
     116                         (p seq))
     117                     (set! seq (cddr seq))
     118                     (cond ((less? (car y) (car x))
     119                            (set-car! p y)
     120                            (set-car! (cdr p) x)))
     121                     (set-cdr! (cdr p) '())
     122                     p))
     123          ((= n 1) (let ((p seq))
     124                     (set! seq (cdr seq))
     125                     (set-cdr! p '())
     126                     p))
     127          (else '())))
     128  (define (key-wrap! lst)
     129    (cond ((null? lst))
     130          (else (set-car! lst (cons (key (car lst)) (car lst)))
     131                (key-wrap! (cdr lst)))))
     132  (define (key-unwrap! lst)
     133    (cond ((null? lst))
     134          (else (set-car! lst (cdar lst))
     135                (key-unwrap! (cdr lst)))))
     136  (key-wrap! seq)
     137  (set! seq (step (length seq)))
     138  (key-unwrap! seq)
     139  seq)
     140
     141(define (rank-1-array->list array)
     142  (define dimensions (array-dimensions array))
     143  (do ((idx (+ -1 (car dimensions)) (+ -1 idx))
     144       (lst '() (cons (array-ref array idx) lst)))
     145      ((< idx 0) lst)))
    146146
    147147;;; (sort! sequence less?)
     
    153153;@
    154154(define (sort! seq less? . opt-key)
    155   (define ret (sort:sort! seq (sort:make-predicate 'sort! less? opt-key)))
    156   (if (not (eq? ret seq))
    157       (do ((crt ret (cdr crt)))
    158           ((eq? (cdr crt) seq)
    159            (set-cdr! crt ret)
    160            (let ((scar (car seq)) (scdr (cdr seq)))
    161              (set-car! seq (car ret)) (set-cdr! seq (cdr ret))
    162              (set-car! ret scar) (set-cdr! ret scdr)))))
    163   seq)
     155  (define key (if (null? opt-key) identity (car opt-key)))
     156  (cond ((array? seq)
     157         (let ((dims (array-dimensions seq)))
     158           (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
     159                        (cdr sorted))
     160                (i 0 (+ i 1)))
     161               ((null? sorted) seq)
     162             (array-set! seq (car sorted) i))))
     163        (else                         ; otherwise, assume it is a list
     164         (let ((ret (sort:sort-list! seq less? key)))
     165           (if (not (eq? ret seq))
     166               (do ((crt ret (cdr crt)))
     167                   ((eq? (cdr crt) seq)
     168                    (set-cdr! crt ret)
     169                    (let ((scar (car seq)) (scdr (cdr seq)))
     170                      (set-car! seq (car ret)) (set-cdr! seq (cdr ret))
     171                      (set-car! ret scar) (set-cdr! ret scdr)))))
     172           seq))))
    164173
    165174;;; (sort sequence less?)
     
    171180;@
    172181(define (sort seq less? . opt-key)
    173   (set! less? (sort:make-predicate 'sort less? opt-key))
     182  (define key (if (null? opt-key) identity (car opt-key)))
    174183  (cond ((array? seq)
    175          (let ((dimensions (array-dimensions seq)))
    176            (define newra (apply make-array seq dimensions))
    177            (do ((sorted (sort:sort! (rank-1-array->list seq) less?)
    178                         (cdr sorted))
    179                 (i 0 (+ i 1)))
    180                ((null? sorted) newra)
    181              (array-set! newra (car sorted) i))))
    182         (else (sort:sort! (append seq '()) less?))))
    183 
     184         (let ((dims (array-dimensions seq)))
     185           (define newra (apply make-array seq dims))
     186           (do ((sorted (sort:sort-list! (rank-1-array->list seq) less? key)
     187                        (cdr sorted))
     188                (i 0 (+ i 1)))
     189               ((null? sorted) newra)
     190             (array-set! newra (car sorted) i))))
     191        (else (sort:sort-list! (append seq '()) less? key))))
  • srfi-95/srfi-95.setup

    r2184 r2305  
    44 'srfi-95
    55 '("srfi-95.html" "srfi-95.so")
    6  '((version 1.0)
     6 '((version 1.1)
    77   (documentation "srfi-95.html")
    88   (exports sort sort! sorted? merge merge!) ) )
  • wiki/srfi-95

    r2176 r2305  
    66for more information.
    77
     8Note: This egg overrides the
     9{{sort}},
     10{{sort!}},
     11{{sorted?}},
     12{{merge!}}, and
     13{{merge!}} procedures in the Chicken unit ''extras''.
     14
    815== Authors
    916
     
    1219== Version
    1320
     21; 1.1 : Updated version from SRFI
    1422; 1.0 : Initial version
    1523
Note: See TracChangeset for help on using the changeset viewer.