port to chicken

1 files changed, 90 insertions, 0 deletions

diff --git a/tests/run.scm b/tests/run.scm
new file mode 100644
index 0000000..5681733
--- /dev/null
+++ b/tests/run.scm
@@ -0,0 +1,90 @@
+(import r7rs)
+
+(import test
+        (scheme base)
+        (srfi 1)
+        (srfi 128)
+        (only (srfi 132) list-sort)
+        (srfi 228))
+
+;;; Chicken's SRFI-128 does not have SRFI-162 extensions.
+
+(define string-ci-comparator
+  (make-comparator
+   string?
+   string-ci=?
+   string-ci<?
+   string-ci-hash))
+
+(define-record-type Person
+    (make-person first-name last-name)
+    person?
+  (first-name person-first-name)
+  (last-name person-last-name))
+
+(define person-name-comparator
+  (make-product-comparator
+   (make-wrapper-comparator person? person-last-name string-ci-comparator)
+   (make-wrapper-comparator person? person-first-name string-ci-comparator)))
+
+(test-group "simple"
+  (test-assert
+   (<? person-name-comparator
+       (make-person "John" "Cowan")
+       (make-person "Daphne" "Preston-Kendal")))
+
+  (test-assert
+   (>? person-name-comparator
+       (make-person "Tom" "Smith")
+       (make-person "John" "Smith"))))
+
+(define-record-type Book
+    (make-book author title)
+    book?
+  (author book-author)
+  (title book-title))
+
+(define book-comparator
+  (make-product-comparator
+   (make-wrapper-comparator book? book-author person-name-comparator)
+   (make-wrapper-comparator book? book-title string-ci-comparator)))
+
+(define-record-type CD
+    (make-cd artist title)
+    cd?
+  (artist cd-artist)
+  (title cd-title))
+
+(define cd-comparator
+  (make-product-comparator
+   (make-wrapper-comparator cd? cd-artist person-name-comparator)
+   (make-wrapper-comparator cd? cd-title string-ci-comparator)))
+
+(define item-comparator
+  (make-sum-comparator book-comparator cd-comparator))
+
+(test-group "nested"
+  (let* ((beatles (make-person "The" "Beatles"))
+         (abbey-road (make-cd beatles "Abbey Road"))
+         (deutsche-grammatik
+          (make-book (make-person "Jacob" "Grimm") "Deutsche Grammatik"))
+         (sonnets (make-book (make-person "William" "Shakespeare") "Sonnets"))
+         (mnd (make-book (make-person "William" "Shakespeare")
+                         "A Midsummer Night’s Dream"))
+         (bob (make-cd (make-person "Bob" "Dylan") "Blonde on Blonde"))
+         (revolver (make-cd (make-person "The" "Beatles") "Revolver")))
+  (test
+   (list deutsche-grammatik
+         mnd
+         sonnets
+         abbey-road
+         revolver
+         bob)
+   (list-sort
+    (lambda (a b) (<? item-comparator a b))
+    (list abbey-road
+          deutsche-grammatik
+          sonnets
+          mnd
+          bob
+          revolver)))))