From 0c58697abddf5c5c10625656d69c273bfce1751a Mon Sep 17 00:00:00 2001 From: Ancker-0 Date: Mon, 2 Dec 2024 12:07:25 +0800 Subject: [PATCH 1/5] Implement (liii sort) --- goldfish/liii/sort.scm | 21 ++++++ goldfish/srfi/srfi-132.scm | 108 ++++++++++++++++++++++++++++++ tests/goldfish/liii/sort-test.scm | 59 ++++++++++++++++ 3 files changed, 188 insertions(+) create mode 100644 goldfish/liii/sort.scm create mode 100644 goldfish/srfi/srfi-132.scm create mode 100644 tests/goldfish/liii/sort-test.scm diff --git a/goldfish/liii/sort.scm b/goldfish/liii/sort.scm new file mode 100644 index 00000000..47a51ce5 --- /dev/null +++ b/goldfish/liii/sort.scm @@ -0,0 +1,21 @@ +; +; Copyright (C) 2024 The Goldfish Scheme Authors +; +; Licensed under the Apache License, Version 2.0 (the "License"); +; you may not use this file except in compliance with the License. +; You may obtain a copy of the License at +; +; http://www.apache.org/licenses/LICENSE-2.0 +; +; Unless required by applicable law or agreed to in writing, software +; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +; License for the specific language governing permissions and limitations +; under the License. +; + +(define-library (liii sort) +(export list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort + list-merge! list-sort! list-stable-sort! vector-merge! vector-sort! vector-stable-sort!) +(import (srfi srfi-132)) +) diff --git a/goldfish/srfi/srfi-132.scm b/goldfish/srfi/srfi-132.scm new file mode 100644 index 00000000..633685cf --- /dev/null +++ b/goldfish/srfi/srfi-132.scm @@ -0,0 +1,108 @@ +; +; Copyright (C) 2024 The Goldfish Scheme Authors +; +; Licensed under the Apache License, Version 2.0 (the "License"); +; you may not use this file except in compliance with the License. +; You may obtain a copy of the License at +; +; http://www.apache.org/licenses/LICENSE-2.0 +; +; Unless required by applicable law or agreed to in writing, software +; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +; License for the specific language governing permissions and limitations +; under the License. +; + +(define-library (srfi srfi-132) +(export list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort + list-merge! list-sort! list-stable-sort! vector-merge! vector-sort! vector-stable-sort!) +(import (liii list) + (scheme case-lambda)) +(begin + + (define-macro (trace-define head . body) + (let ((f-name (car head)) + (f-args (cdr head))) + (format () "~a\n" `(define ,head + (let-values ((res (begin ,@body))) + (format () "~a\n=> ~a\n" (list ,f-name ,@f-args) res) + (apply values res)))) + `(define ,head + (let-values ((res (begin ,@body))) + (format () "~a\n=> ~a\n" (list ,f-name ,@f-args) res) + (apply values res))))) + + (define-macro (trace-lambda f-name head . body) + (let ((f-args head)) + `(lambda ,head + (let-values ((res (begin ,@body))) + (format () "~a\n=> ~a\n" (list ,f-name ,@f-args) res) + (apply values res))))) + + (define (list-merge less-p lis1 lis2) + (let loop + ((res '()) + (lis1 lis1) + (lis2 lis2)) + (cond + ((and (null? lis1) (null? lis2)) (reverse res)) + ((null? lis1) (loop (cons (car lis2) res) lis1 (cdr lis2))) + ((null? lis2) (loop (cons (car lis1) res) lis2 (cdr lis1))) + ((less-p (car lis2) (car lis1)) (loop (cons (car lis2) res) lis1 (cdr lis2))) + (else (loop (cons (car lis1) res) (cdr lis1) lis2))))) + + (define (subvector->list v start end) + (do ((r '() (cons (vector-ref v p) r)) + (p start (+ 1 p))) + ((>= p end) (reverse r)))) + + (define vector-merge + (case-lambda + ((less-p v1 v2) + (list->vector (list-merge less-p (vector->list v1) (vector->list v2)))) + ((less-p v1 v2 start1) + (list->vector (list-merge less-p (subvector->list v1 start1 (vector-length v1)) (vector->list v2)))) + ((less-p v1 v2 start1 end1) + (list->vector (list-merge less-p (subvector->list v1 start1 end1) (vector->list v2)))) + ((less-p v1 v2 start1 end1 start2) + (list->vector (list-merge less-p (subvector->list v1 start1 end1) (subvector->list v2 start2 (vector-length v2))))) + ((less-p v1 v2 start1 end1 start2 end2) + (list->vector (list-merge less-p (subvector->list v1 start1 end1) (subvector->list v2 start2 end2)))))) + + (define (list-stable-sort less-p lis) + (define (sort l r) + (cond + ((= l r) '()) + ((= (+ l 1) r) (list (list-ref lis l))) + (else + (let* ((mid (quotient (+ l r) 2)) + (l-sorted (sort l mid)) + (r-sorted (sort mid r))) + (list-merge less-p l-sorted r-sorted))))) + (sort 0 (length lis))) + + (define list-sort list-stable-sort) + + (define vector-stable-sort + (case-lambda + ((less-p v) + (list->vector (list-stable-sort less-p (vector->list v)))) + ((less-p v start) + (list->vector (list-stable-sort less-p (subvector->list v start (vector-length v))))) + ((less-p v start end) + (list->vector (list-stable-sort less-p (subvector->list v start end)))))) + + (define vector-sort vector-stable-sort) + + (define-macro (define/! x) + (when (not (symbol? x)) (error 'syntax-error)) + ;(format () "~a " (string->symbol (string-append (symbol->string x) "_"))) + `(define ,(string->symbol (string-append (symbol->string x) "!")) ,x)) + (define-macro (define-more/! . xs) + `(begin ,@(map (lambda (x) `(define/! ,x)) xs))) + + (define-more/! list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort) + +) ; end of begin +) ; end of library diff --git a/tests/goldfish/liii/sort-test.scm b/tests/goldfish/liii/sort-test.scm new file mode 100644 index 00000000..1afaf667 --- /dev/null +++ b/tests/goldfish/liii/sort-test.scm @@ -0,0 +1,59 @@ +; +; Copyright (C) 2024 The Goldfish Scheme Authors +; +; Licensed under the Apache License, Version 2.0 (the "License"); +; you may not use this file except in compliance with the License. +; You may obtain a copy of the License at +; +; http://www.apache.org/licenses/LICENSE-2.0 +; +; Unless required by applicable law or agreed to in writing, software +; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT +; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the +; License for the specific language governing permissions and limitations +; under the License. +; + +(import (liii check) + (liii sort)) + +(check-set-mode! 'report-failed) + +(define (sorted? less-p lis) + (if (< (length lis) 2) + #t + (and (not (less-p (cadr lis) (car lis))) + (sorted? less-p (cdr lis))))) + +(define (vector-sorted? less-p v) + (sorted? less-p (vector->list v))) + +(define (pair-< x y) + (< (car x) (car y))) + +(define (pair-full-< x y) + (cond + ((not (= (car x) (car y))) (< (car x) (car y))) + (else (< (cdr y) (cdr x))))) + +(check-false (sorted? < '(1 5 1 0 -1 9 2 4 3))) + +(check-true (sorted? < (list-sort < '(1 5 1 0 -1 9 2 4 3)))) +(check-true (sorted? < (list-stable-sort < '(1 5 1 0 -1 9 2 4 3)))) +(check-true (sorted? pair-< (list-merge pair-< '((1 . 1) (1 . 2) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) +(check (list-merge pair-< '((1 . 1) (1 . 2) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))) + => '((1 . 1) (1 . 2) (1 . 3) (2 . 1) (3 . 1) (3 . 2) (4 . 1))) +(check-true (sorted? pair-full-< (list-merge pair-full-< '((1 . 2) (1 . 1) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) +(check (list-merge pair-full-< '((1 . 2) (1 . 1) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))) + => '((1 . 3) (1 . 2) (1 . 1) (2 . 1) (3 . 2) (3 . 1) (4 . 1))) + +(check-true (vector-sorted? < (vector-sort < #(1 5 1 0 -1 9 2 4 3)))) +(check-true (vector-sorted? < (vector-stable-sort < #(1 5 1 0 -1 9 2 4 3)))) +(check-true (vector-sorted? pair-< (vector-merge pair-< #((1 . 1) (1 . 2) (3 . 1)) #((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) +(check (vector-merge pair-< #((1 . 1) (1 . 2) (3 . 1)) #((1 . 3) (2 . 1) (3 . 2) (4 . 1))) + => #((1 . 1) (1 . 2) (1 . 3) (2 . 1) (3 . 1) (3 . 2) (4 . 1))) +(check-true (vector-sorted? pair-full-< (vector-merge pair-full-< #((1 . 2) (1 . 1) (3 . 1)) #((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) +(check (vector-merge pair-full-< #((1 . 2) (1 . 1) (3 . 1)) #((1 . 3) (2 . 1) (3 . 2) (4 . 1))) + => #((1 . 3) (1 . 2) (1 . 1) (2 . 1) (3 . 2) (3 . 1) (4 . 1))) + +(check-report) From 7a622ee000d1f6d2461bf9b1b9800fa40db36d0a Mon Sep 17 00:00:00 2001 From: Ancker-0 Date: Mon, 2 Dec 2024 12:41:25 +0800 Subject: [PATCH 2/5] reorganize the code --- goldfish/srfi/srfi-132.scm | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/goldfish/srfi/srfi-132.scm b/goldfish/srfi/srfi-132.scm index 633685cf..5a8aa4e2 100644 --- a/goldfish/srfi/srfi-132.scm +++ b/goldfish/srfi/srfi-132.scm @@ -52,6 +52,20 @@ ((less-p (car lis2) (car lis1)) (loop (cons (car lis2) res) lis1 (cdr lis2))) (else (loop (cons (car lis1) res) (cdr lis1) lis2))))) + (define (list-stable-sort less-p lis) + (define (sort l r) + (cond + ((= l r) '()) + ((= (+ l 1) r) (list (list-ref lis l))) + (else + (let* ((mid (quotient (+ l r) 2)) + (l-sorted (sort l mid)) + (r-sorted (sort mid r))) + (list-merge less-p l-sorted r-sorted))))) + (sort 0 (length lis))) + + (define list-sort list-stable-sort) + (define (subvector->list v start end) (do ((r '() (cons (vector-ref v p) r)) (p start (+ 1 p))) @@ -70,20 +84,6 @@ ((less-p v1 v2 start1 end1 start2 end2) (list->vector (list-merge less-p (subvector->list v1 start1 end1) (subvector->list v2 start2 end2)))))) - (define (list-stable-sort less-p lis) - (define (sort l r) - (cond - ((= l r) '()) - ((= (+ l 1) r) (list (list-ref lis l))) - (else - (let* ((mid (quotient (+ l r) 2)) - (l-sorted (sort l mid)) - (r-sorted (sort mid r))) - (list-merge less-p l-sorted r-sorted))))) - (sort 0 (length lis))) - - (define list-sort list-stable-sort) - (define vector-stable-sort (case-lambda ((less-p v) From 207058b554f6a04df7f5ef42435c43def2073cfc Mon Sep 17 00:00:00 2001 From: Ancker-0 Date: Mon, 2 Dec 2024 13:18:01 +0800 Subject: [PATCH 3/5] Abandon some implementations which violates SRFI 132 --- goldfish/srfi/srfi-132.scm | 60 +++++++++++++++++++++++++------------- 1 file changed, 40 insertions(+), 20 deletions(-) diff --git a/goldfish/srfi/srfi-132.scm b/goldfish/srfi/srfi-132.scm index 5a8aa4e2..f7ac2f4d 100644 --- a/goldfish/srfi/srfi-132.scm +++ b/goldfish/srfi/srfi-132.scm @@ -15,9 +15,11 @@ ; (define-library (srfi srfi-132) -(export list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort +(export list-sorted? vector-sorted? + list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort list-merge! list-sort! list-stable-sort! vector-merge! vector-sort! vector-stable-sort!) (import (liii list) + (liii error) (scheme case-lambda)) (begin @@ -40,6 +42,23 @@ (format () "~a\n=> ~a\n" (list ,f-name ,@f-args) res) (apply values res))))) + (define (list-sorted? less-p lis) + (if (null? lis) + #t + (do ((first lis (cdr first)) + (second (cdr lis) (cdr second)) + (res #t (not (less-p (car second) (car first))))) + ((or (null? second) (not res)) res)))) + + ; TODO optional parameters + (define (vector-sorted? less-p v) + (let ((start 0) + (end (length v))) + (do ((first start (+ 1 first)) + (second (+ 1 start) (+ 1 second)) + (res #t (not (less-p (vector-ref v second) (vector-ref v first))))) + ((or (>= second end) (not res)) res)))) + (define (list-merge less-p lis1 lis2) (let loop ((res '()) @@ -52,6 +71,9 @@ ((less-p (car lis2) (car lis1)) (loop (cons (car lis2) res) lis1 (cdr lis2))) (else (loop (cons (car lis1) res) (cdr lis1) lis2))))) + ; this list-merge! violates SRFI 132, since it does not satisfy the constant running space constraint specified in SRFI 132, and does not work "in place" + (define list-merge! list-merge) + (define (list-stable-sort less-p lis) (define (sort l r) (cond @@ -65,6 +87,22 @@ (sort 0 (length lis))) (define list-sort list-stable-sort) + (define list-sort! list-stable-sort) + (define list-stable-sort! list-stable-sort) + + (define vector-stable-sort + (case-lambda + ((less-p v) + (list->vector (list-stable-sort less-p (vector->list v)))) + ((less-p v start) + (list->vector (list-stable-sort less-p (subvector->list v start (vector-length v))))) + ((less-p v start end) + (list->vector (list-stable-sort less-p (subvector->list v start end)))))) + + (define vector-sort vector-stable-sort) + + (define (vector-sort! . r) (???)) + (define (vector-stable-sort! . r) (???)) (define (subvector->list v start end) (do ((r '() (cons (vector-ref v p) r)) @@ -84,25 +122,7 @@ ((less-p v1 v2 start1 end1 start2 end2) (list->vector (list-merge less-p (subvector->list v1 start1 end1) (subvector->list v2 start2 end2)))))) - (define vector-stable-sort - (case-lambda - ((less-p v) - (list->vector (list-stable-sort less-p (vector->list v)))) - ((less-p v start) - (list->vector (list-stable-sort less-p (subvector->list v start (vector-length v))))) - ((less-p v start end) - (list->vector (list-stable-sort less-p (subvector->list v start end)))))) - - (define vector-sort vector-stable-sort) - - (define-macro (define/! x) - (when (not (symbol? x)) (error 'syntax-error)) - ;(format () "~a " (string->symbol (string-append (symbol->string x) "_"))) - `(define ,(string->symbol (string-append (symbol->string x) "!")) ,x)) - (define-macro (define-more/! . xs) - `(begin ,@(map (lambda (x) `(define/! ,x)) xs))) - - (define-more/! list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort) + (define (vector-merge! . r) (???)) ) ; end of begin ) ; end of library From e5315a73aed83f9dd2cd18b34da473c5e2e71c8f Mon Sep 17 00:00:00 2001 From: Ancker-0 Date: Mon, 2 Dec 2024 13:30:43 +0800 Subject: [PATCH 4/5] Add tests --- goldfish/liii/sort.scm | 3 ++- tests/goldfish/liii/sort-test.scm | 20 ++++++-------------- 2 files changed, 8 insertions(+), 15 deletions(-) diff --git a/goldfish/liii/sort.scm b/goldfish/liii/sort.scm index 47a51ce5..b7476dc9 100644 --- a/goldfish/liii/sort.scm +++ b/goldfish/liii/sort.scm @@ -15,7 +15,8 @@ ; (define-library (liii sort) -(export list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort +(export list-sorted? vector-sorted? + list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort list-merge! list-sort! list-stable-sort! vector-merge! vector-sort! vector-stable-sort!) (import (srfi srfi-132)) ) diff --git a/tests/goldfish/liii/sort-test.scm b/tests/goldfish/liii/sort-test.scm index 1afaf667..39597edf 100644 --- a/tests/goldfish/liii/sort-test.scm +++ b/tests/goldfish/liii/sort-test.scm @@ -19,15 +19,6 @@ (check-set-mode! 'report-failed) -(define (sorted? less-p lis) - (if (< (length lis) 2) - #t - (and (not (less-p (cadr lis) (car lis))) - (sorted? less-p (cdr lis))))) - -(define (vector-sorted? less-p v) - (sorted? less-p (vector->list v))) - (define (pair-< x y) (< (car x) (car y))) @@ -36,14 +27,15 @@ ((not (= (car x) (car y))) (< (car x) (car y))) (else (< (cdr y) (cdr x))))) -(check-false (sorted? < '(1 5 1 0 -1 9 2 4 3))) +(check-false (list-sorted? < '(1 5 1 0 -1 9 2 4 3))) +(check-false (vector-sorted? < #(1 5 1 0 -1 9 2 4 3))) -(check-true (sorted? < (list-sort < '(1 5 1 0 -1 9 2 4 3)))) -(check-true (sorted? < (list-stable-sort < '(1 5 1 0 -1 9 2 4 3)))) -(check-true (sorted? pair-< (list-merge pair-< '((1 . 1) (1 . 2) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) +(check-true (list-sorted? < (list-sort < '(1 5 1 0 -1 9 2 4 3)))) +(check-true (list-sorted? < (list-stable-sort < '(1 5 1 0 -1 9 2 4 3)))) +(check-true (list-sorted? pair-< (list-merge pair-< '((1 . 1) (1 . 2) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) (check (list-merge pair-< '((1 . 1) (1 . 2) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))) => '((1 . 1) (1 . 2) (1 . 3) (2 . 1) (3 . 1) (3 . 2) (4 . 1))) -(check-true (sorted? pair-full-< (list-merge pair-full-< '((1 . 2) (1 . 1) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) +(check-true (list-sorted? pair-full-< (list-merge pair-full-< '((1 . 2) (1 . 1) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) (check (list-merge pair-full-< '((1 . 2) (1 . 1) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))) => '((1 . 3) (1 . 2) (1 . 1) (2 . 1) (3 . 2) (3 . 1) (4 . 1))) From 0943e4a71dbb3116c201f3908072bbb0c8072091 Mon Sep 17 00:00:00 2001 From: Ancker-0 Date: Mon, 2 Dec 2024 14:20:41 +0800 Subject: [PATCH 5/5] Literate (liii sort) --- goldfish/liii/sort.scm | 4 +- goldfish/srfi/srfi-132.scm | 20 +- liii_sort.tmu | 474 ++++++++++++++++++++++++++++++ tests/goldfish/liii/sort-test.scm | 1 + 4 files changed, 478 insertions(+), 21 deletions(-) create mode 100644 liii_sort.tmu diff --git a/goldfish/liii/sort.scm b/goldfish/liii/sort.scm index b7476dc9..50beef81 100644 --- a/goldfish/liii/sort.scm +++ b/goldfish/liii/sort.scm @@ -18,5 +18,5 @@ (export list-sorted? vector-sorted? list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort list-merge! list-sort! list-stable-sort! vector-merge! vector-sort! vector-stable-sort!) -(import (srfi srfi-132)) -) +(import (srfi srfi-132))) + diff --git a/goldfish/srfi/srfi-132.scm b/goldfish/srfi/srfi-132.scm index f7ac2f4d..d887677c 100644 --- a/goldfish/srfi/srfi-132.scm +++ b/goldfish/srfi/srfi-132.scm @@ -23,25 +23,6 @@ (scheme case-lambda)) (begin - (define-macro (trace-define head . body) - (let ((f-name (car head)) - (f-args (cdr head))) - (format () "~a\n" `(define ,head - (let-values ((res (begin ,@body))) - (format () "~a\n=> ~a\n" (list ,f-name ,@f-args) res) - (apply values res)))) - `(define ,head - (let-values ((res (begin ,@body))) - (format () "~a\n=> ~a\n" (list ,f-name ,@f-args) res) - (apply values res))))) - - (define-macro (trace-lambda f-name head . body) - (let ((f-args head)) - `(lambda ,head - (let-values ((res (begin ,@body))) - (format () "~a\n=> ~a\n" (list ,f-name ,@f-args) res) - (apply values res))))) - (define (list-sorted? less-p lis) (if (null? lis) #t @@ -126,3 +107,4 @@ ) ; end of begin ) ; end of library + diff --git a/liii_sort.tmu b/liii_sort.tmu new file mode 100644 index 00000000..7d14c632 --- /dev/null +++ b/liii_sort.tmu @@ -0,0 +1,474 @@ +> + +> + +<\body> + + + + + <\scm-chunk|goldfish/liii/sort.scm|false|true> + ; + + ; Copyright (C) 2024 The Goldfish Scheme Authors + + ; + + ; Licensed under the Apache License, Version 2.0 (the "License"); + + ; you may not use this file except in compliance with the License. + + ; You may obtain a copy of the License at + + ; + + ; http://www.apache.org/licenses/LICENSE-2.0 + + ; + + ; Unless required by applicable law or agreed to in writing, software + + ; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + + ; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + + ; License for the specific language governing permissions and limitations + + ; under the License. + + ; + + \; + + + <\scm-chunk|goldfish/srfi/srfi-132.scm|false|true> + ; + + ; Copyright (C) 2024 The Goldfish Scheme Authors + + ; + + ; Licensed under the Apache License, Version 2.0 (the "License"); + + ; you may not use this file except in compliance with the License. + + ; You may obtain a copy of the License at + + ; + + ; http://www.apache.org/licenses/LICENSE-2.0 + + ; + + ; Unless required by applicable law or agreed to in writing, software + + ; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + + ; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + + ; License for the specific language governing permissions and limitations + + ; under the License. + + ; + + \; + + + <\scm-chunk|tests/goldfish/liii/sort-test.scm|false|true> + ; + + ; Copyright (C) 2024 The Goldfish Scheme Authors + + ; + + ; Licensed under the Apache License, Version 2.0 (the "License"); + + ; you may not use this file except in compliance with the License. + + ; You may obtain a copy of the License at + + ; + + ; http://www.apache.org/licenses/LICENSE-2.0 + + ; + + ; Unless required by applicable law or agreed to in writing, software + + ; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT + + ; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the + + ; License for the specific language governing permissions and limitations + + ; under the License. + + ; + + \; + + + + + <\scm-chunk|goldfish/liii/sort.scm|true|false> + (define-library (liii sort) + + (export list-sorted? vector-sorted? + + \ \ \ \ \ \ \ \ list-merge \ list-sort \ list-stable-sort \ vector-merge \ vector-sort \ vector-stable-sort + + \ \ \ \ \ \ \ \ list-merge! list-sort! list-stable-sort! vector-merge! vector-sort! vector-stable-sort!) + + (import (srfi srfi-132))) + + \; + + + <\scm-chunk|goldfish/srfi/srfi-132.scm|true|true> + (define-library (srfi srfi-132) + + (export list-sorted? vector-sorted? + + \ \ \ \ \ \ \ \ list-merge \ list-sort \ list-stable-sort \ vector-merge \ vector-sort \ vector-stable-sort + + \ \ \ \ \ \ \ \ list-merge! list-sort! list-stable-sort! vector-merge! vector-sort! vector-stable-sort!) + + (import (liii list) + + \ \ \ \ \ \ \ \ (liii error) + + \ \ \ \ \ \ \ \ (scheme case-lambda)) + + (begin + + \; + + + <\section> + 实现 + + + + + 判断 list 或 vector 是否有序。 尚未实现可选参数 start 和 end。 + + <\scm-chunk|goldfish/srfi/srfi-132.scm|true|true> + \ \ (define (list-sorted? less-p lis) + + \ \ \ \ (if (null? lis) + + \ \ \ \ \ \ #t + + \ \ \ \ \ \ (do ((first lis (cdr first)) + + \ \ \ \ \ \ \ \ \ \ \ (second (cdr lis) (cdr second)) + + \ \ \ \ \ \ \ \ \ \ \ (res #t (not (less-p (car second) (car first))))) + + \ \ \ \ \ \ \ \ ((or (null? second) (not res)) res)))) + + \; + + \ \ ; TODO optional parameters + + \ \ (define (vector-sorted? less-p v) + + \ \ \ \ (let ((start 0) + + \ \ \ \ \ \ \ \ \ \ (end (length v))) + + \ \ \ \ \ \ (do ((first start (+ 1 first)) + + \ \ \ \ \ \ \ \ \ \ \ (second (+ 1 start) (+ 1 second)) + + \ \ \ \ \ \ \ \ \ \ \ (res #t (not (less-p (vector-ref v second) (vector-ref v first))))) + + \ \ \ \ \ \ \ \ ((or (\= second end) (not res)) res)))) + + \; + + + + + 归并排序。需要注意 不必修改原 list，但 要保证修改原 vector。 + + <\scm-chunk|goldfish/srfi/srfi-132.scm|true|true> + \ \ (define (list-merge less-p lis1 lis2) + + \ \ \ \ (let loop + + \ \ \ \ \ \ ((res '()) + + \ \ \ \ \ \ \ (lis1 lis1) + + \ \ \ \ \ \ \ (lis2 lis2)) + + \ \ \ \ \ \ (cond + + \ \ \ \ \ \ \ \ ((and (null? lis1) (null? lis2)) (reverse res)) + + \ \ \ \ \ \ \ \ ((null? lis1) (loop (cons (car lis2) res) lis1 (cdr lis2))) + + \ \ \ \ \ \ \ \ ((null? lis2) (loop (cons (car lis1) res) lis2 (cdr lis1))) + + \ \ \ \ \ \ \ \ ((less-p (car lis2) (car lis1)) (loop (cons (car lis2) res) lis1 (cdr lis2))) + + \ \ \ \ \ \ \ \ (else (loop (cons (car lis1) res) (cdr lis1) lis2))))) + + \; + + \ \ ; this list-merge! violates SRFI 132, since it does not satisfy the constant running space constraint specified in SRFI 132, and does not work "in place" + + \ \ (define list-merge! list-merge) + + \; + + \ \ (define (list-stable-sort less-p lis) + + \ \ \ \ (define (sort l r) + + \ \ \ \ \ \ (cond + + \ \ \ \ \ \ \ \ ((= l r) '()) + + \ \ \ \ \ \ \ \ ((= (+ l 1) r) (list (list-ref lis l))) + + \ \ \ \ \ \ \ \ (else + + \ \ \ \ \ \ \ \ \ \ (let* ((mid (quotient (+ l r) 2)) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (l-sorted (sort l mid)) + + \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ \ (r-sorted (sort mid r))) + + \ \ \ \ \ \ \ \ \ \ \ \ (list-merge less-p l-sorted r-sorted))))) + + \ \ \ \ (sort 0 (length lis))) + + \; + + \ \ (define list-sort list-stable-sort) + + \ \ (define list-sort! list-stable-sort) + + \ \ (define list-stable-sort! list-stable-sort) + + \; + + + + + 无副作用时调用 list 相关函数实现。原地排序尚未实现。 + + <\scm-chunk|goldfish/srfi/srfi-132.scm|true|true> + \ \ (define vector-stable-sort + + \ \ \ \ (case-lambda + + \ \ \ \ \ \ ((less-p v) + + \ \ \ \ \ \ \ (list-\vector (list-stable-sort less-p (vector-\list v)))) + + \ \ \ \ \ \ ((less-p v start) + + \ \ \ \ \ \ \ (list-\vector (list-stable-sort less-p (subvector-\list v start (vector-length v))))) + + \ \ \ \ \ \ ((less-p v start end) + + \ \ \ \ \ \ \ (list-\vector (list-stable-sort less-p (subvector-\list v start end)))))) + + \; + + \ \ (define vector-sort vector-stable-sort) + + \; + + \ \ (define (vector-sort! . r) (???)) + + \ \ (define (vector-stable-sort! . r) (???)) + + \; + + \ \ (define (subvector-\list v start end) + + \ \ \ \ (do ((r '() (cons (vector-ref v p) r)) + + \ \ \ \ \ \ \ \ \ (p start (+ 1 p))) + + \ \ \ \ \ \ ((\= p end) (reverse r)))) + + \; + + \ \ (define vector-merge + + \ \ \ \ (case-lambda + + \ \ \ \ \ \ ((less-p v1 v2) + + \ \ \ \ \ \ \ (list-\vector (list-merge less-p (vector-\list v1) (vector-\list v2)))) + + \ \ \ \ \ \ ((less-p v1 v2 start1) + + \ \ \ \ \ \ \ (list-\vector (list-merge less-p (subvector-\list v1 start1 (vector-length v1)) (vector-\list v2)))) + + \ \ \ \ \ \ ((less-p v1 v2 start1 end1) + + \ \ \ \ \ \ \ (list-\vector (list-merge less-p (subvector-\list v1 start1 end1) (vector-\list v2)))) + + \ \ \ \ \ \ ((less-p v1 v2 start1 end1 start2) + + \ \ \ \ \ \ \ (list-\vector (list-merge less-p (subvector-\list v1 start1 end1) (subvector-\list v2 start2 (vector-length v2))))) + + \ \ \ \ \ \ ((less-p v1 v2 start1 end1 start2 end2) + + \ \ \ \ \ \ \ (list-\vector (list-merge less-p (subvector-\list v1 start1 end1) (subvector-\list v2 start2 end2)))))) + + \; + + \ \ (define (vector-merge! . r) (???)) + + \; + + + + + <\scm-chunk|tests/goldfish/liii/sort-test.scm|true|false> + (import (liii check) + + \ \ \ \ \ \ \ \ (liii sort)) + + \; + + (check-set-mode! 'report-failed) + + \; + + (define (pair-\ x y) + + \ \ (\ (car x) (car y))) + + \; + + (define (pair-full-\ x y) + + \ \ (cond + + \ \ \ \ ((not (= (car x) (car y))) (\ (car x) (car y))) + + \ \ \ \ (else (\ (cdr y) (cdr x))))) + + \; + + (check-false (list-sorted? \ '(1 5 1 0 -1 9 2 4 3))) + + (check-false (vector-sorted? \ #(1 5 1 0 -1 9 2 4 3))) + + \; + + (check-true (list-sorted? \ (list-sort \ '(1 5 1 0 -1 9 2 4 3)))) + + (check-true (list-sorted? \ (list-stable-sort \ '(1 5 1 0 -1 9 2 4 3)))) + + (check-true (list-sorted? pair-\ (list-merge pair-\ '((1 . 1) (1 . 2) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) + + (check (list-merge pair-\ '((1 . 1) (1 . 2) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))) + + \ \ \ \ \ \ \ =\ '((1 . 1) (1 . 2) (1 . 3) (2 . 1) (3 . 1) (3 . 2) (4 . 1))) + + (check-true (list-sorted? pair-full-\ (list-merge pair-full-\ '((1 . 2) (1 . 1) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) + + (check (list-merge pair-full-\ '((1 . 2) (1 . 1) (3 . 1)) '((1 . 3) (2 . 1) (3 . 2) (4 . 1))) + + \ \ \ \ \ \ \ =\ '((1 . 3) (1 . 2) (1 . 1) (2 . 1) (3 . 2) (3 . 1) (4 . 1))) + + \; + + (check-true (vector-sorted? \ (vector-sort \ #(1 5 1 0 -1 9 2 4 3)))) + + (check-true (vector-sorted? \ (vector-stable-sort \ #(1 5 1 0 -1 9 2 4 3)))) + + (check-true (vector-sorted? pair-\ (vector-merge pair-\ #((1 . 1) (1 . 2) (3 . 1)) #((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) + + (check (vector-merge pair-\ #((1 . 1) (1 . 2) (3 . 1)) #((1 . 3) (2 . 1) (3 . 2) (4 . 1))) + + \ \ \ \ \ \ \ =\ #((1 . 1) (1 . 2) (1 . 3) (2 . 1) (3 . 1) (3 . 2) (4 . 1))) + + (check-true (vector-sorted? pair-full-\ (vector-merge pair-full-\ #((1 . 2) (1 . 1) (3 . 1)) #((1 . 3) (2 . 1) (3 . 2) (4 . 1))))) + + (check (vector-merge pair-full-\ #((1 . 2) (1 . 1) (3 . 1)) #((1 . 3) (2 . 1) (3 . 2) (4 . 1))) + + \ \ \ \ \ \ \ =\ #((1 . 3) (1 . 2) (1 . 1) (2 . 1) (3 . 2) (3 . 1) (4 . 1))) + + \; + + (check-report) + + \; + + + + + <\scm-chunk|goldfish/srfi/srfi-132.scm|true|false> + ) ; end of begin + + ) ; end of library + + \; + + + +<\initial> + <\collection> + + + + + +<\references> + <\collection> + > + > + > + > + > + > + > + > + > + > + > + > + > + > + > + > + > + > + > + + + +<\auxiliary> + <\collection> + <\associate|toc> + |math-font-series||font-size||1(liii sort)> |.>>>>|> + + |math-font-series||1许可证> |.>>>>|> + + |math-font-series||2接口> |.>>>>|> + + |math-font-series||3实现> |.>>>>|> + + |3.1list-sorted?, vector-sorted? |.>>>>|> > + + |3.2list-merge, list-sort, list-stable-sort |.>>>>|> > + + |3.3vector-merge, vector-sort, vector-stable-sort |.>>>>|> > + + |math-font-series||4测试> |.>>>>|> + + |math-font-series||5结尾> |.>>>>|> + + + diff --git a/tests/goldfish/liii/sort-test.scm b/tests/goldfish/liii/sort-test.scm index 39597edf..e46f4c7d 100644 --- a/tests/goldfish/liii/sort-test.scm +++ b/tests/goldfish/liii/sort-test.scm @@ -49,3 +49,4 @@ => #((1 . 3) (1 . 2) (1 . 1) (2 . 1) (3 . 2) (3 . 1) (4 . 1))) (check-report) +