Implement (liii sort)

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))
+)

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

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)