Replete with test cases
diff -Naur srfi-95-old/mulapply.scm srfi-95-new/mulapply.scm --- srfi-95-old/mulapply.scm 1969-12-31 16:00:00.000000000 -0800 +++ srfi-95-new/mulapply.scm 2010-01-15 07:14:01.905945141 -0800 @@ -0,0 +1,29 @@ +; "mulapply.scm" Redefine APPLY take more than 2 arguments. +;Copyright (C) 1991, 2003 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. +;@ +(define apply + (letrec ((apply-2 apply) + (append-to-last + (lambda (lst) + (if (null? (cdr lst)) + (car lst) + (cons (car lst) (append-to-last (cdr lst))))))) + (lambda args + (apply-2 (car args) (append-to-last (cdr args)))))) + diff -Naur srfi-95-old/srfi-95.meta srfi-95-new/srfi-95.meta --- srfi-95-old/srfi-95.meta 1969-12-31 16:00:00.000000000 -0800 +++ srfi-95-new/srfi-95.meta 2010-01-15 07:14:01.905945141 -0800 @@ -0,0 +1,11 @@ +((egg "srfi-95.egg") + (files "vector-lib.scm" + "vector-lib.setup" + "mulapply.scm" + "TODO" + "tests/run.scm") + (category data) + (license "Public Domain") + (author "Richard A. O'Keefe, ported to hygienic Chicken with test suite by Peter Danenberg") + (synopsis "Sorting and merging") + (test-depends test)) diff -Naur srfi-95-old/srfi-95.scm srfi-95-new/srfi-95.scm --- srfi-95-old/srfi-95.scm 1969-12-31 16:00:00.000000000 -0800 +++ srfi-95-new/srfi-95.scm 2010-01-15 07:14:01.905945141 -0800 @@ -0,0 +1,210 @@ +;;; "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. + +;; (require 'array) +;; (require 'multiarg-apply) ; used in SORT + +;;; chicken-specific module +(module +srfi-95 +(sorted? merge merge! sort sort!) + +(import scheme chicken) + +(use data-structures srfi-63) + +(include "mulapply.scm") + +;; (define 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)))) + +) diff -Naur srfi-95-old/srfi-95.setup srfi-95-new/srfi-95.setup --- srfi-95-old/srfi-95.setup 1969-12-31 16:00:00.000000000 -0800 +++ srfi-95-new/srfi-95.setup 2010-01-15 07:14:01.906944836 -0800 @@ -0,0 +1,9 @@ +;;; -*- Hen -*- + +(include "setup-helper") + +(verify-extension-name "srfi-95") + +(setup-shared-extension-module + 'srfi-95 + (extension-version 1.2)) diff -Naur srfi-95-old/tests/run.scm srfi-95-new/tests/run.scm --- srfi-95-old/tests/run.scm 1969-12-31 16:00:00.000000000 -0800 +++ srfi-95-new/tests/run.scm 2010-01-15 07:15:15.341943083 -0800 @@ -0,0 +1,37 @@ +(use srfi-95 test) + +(test-group + "srfi-95" + + (test-assert + "sorted?" + (sorted? '(1 2 3) <)) + + (test + "sorted? with unsorted" + #f + (sorted? '(1 2 3) >)) + + (test-assert + "sorted? with key" + (sorted? '(#\a #\b #\c) < char->integer)) + + (test + "merge" + '(1 2 3 4 5 6) + (merge '(1 2 3) '(4 5 6) <)) + + (test + "merge!" + '(1 2 3 4 5 6) + (merge! '(1 2 3) '(4 5 6) <)) + + (test + "sort" + '(1 2 3) + (sort '(3 2 1) <)) + + (test + "sort!" + '(1 2 3) + (sort! '(3 2 1) <))) diff -Naur srfi-95-old/TODO srfi-95-new/TODO --- srfi-95-old/TODO 1969-12-31 16:00:00.000000000 -0800 +++ srfi-95-new/TODO 2010-01-15 07:14:01.904963845 -0800 @@ -0,0 +1,5 @@ +# -*- mode: org; -*- +* TODO identity + do we really need to import data-structures just for identity? +* TODO mulapply + do we really need to include mulapply.scm?
_______________________________________________ Chicken-users mailing list [email protected] http://lists.nongnu.org/mailman/listinfo/chicken-users
