values lib

5 files changed, 249 insertions, 0 deletions

diff --git a/doc/mcgoron.cond-thunk.values.scm b/doc/mcgoron.cond-thunk.values.scm
new file mode 100644
index 0000000..5f2265f
--- /dev/null
+++ b/doc/mcgoron.cond-thunk.values.scm
@@ -0,0 +1,54 @@
+(((name . "after")
+  (signature syntax-rules (when let =>) (after (clause ...) body ...))
+  (subsigs
+   (clause (pattern
+            ((when conditional))
+            ((let value => formal)))))
+  (desc "
+For each clause,
+
+* If `clause` is `when conditional`, then `conditional` is evaluated. If
+  `conditional` is false, then the `after` expression returns `#f`.
+  Otherwise the rest of the clauses are executed.
+* If `clause` is `let value => formal`, then `value` is evaluated. If
+  `value` returns no values, then the `after` expression returns `#f`.
+  Otherwise, the values returned are bound to `formal` in the next clauses
+  and in the body.
+
+Once all clauses succeed, the `after` clause returns a thunk containing
+body. The free variables bound in and surrounding the `after` expression
+are captured in the thunk."))
+ ((name . "cond-values")
+  (signature syntax-rules () (cond-values clauses ...))
+  (desc "
+A wrapper around `cond-thunk` that returns no values instead of `#f`
+when all clauses are exhausted. This is intended for destructuring
+procedures used by `after`. See `cond-thunk` for more details."))
+ ((name . "pair=>")
+  (signature lambda (x) => (or (values * *) (values)))
+  (tags destructuring)
+  (desc "
+If `x` is a pair, return its car and cdr. Otherwise return no values."))
+ ((name . "length-at-least=>")
+  (signature lambda (whole-list (integer? num)) *)
+  (tags destructuring)
+  (desc "
+* It is an error if `num` is not a positive integer.
+
+If `whole-list` is a proper or improper list of length at least `num`,
+then `num + 1` values are delivered: the first `num` elements and a
+final element with the rest of the list."))
+ ((name. "length=>")
+  (signature lambda (whole-list (integer? num)) *)
+  (tags destructuring)
+  (desc "
+* It is an error if `num` is not a positive integer.
+
+If `whole-list` is a proper list of length `num`, then each element of the
+list is returned as values."))
+ ((name . "apply-after")
+  (signature syntax-rules () ((_ producer consumer)))
+  (desc "
+Evaluates `producer`. If `producer` evaluates to at least one value, then
+return a thunk that, when called, tail-calls `consumer` with the values
+that `producer` produced. Otherwise, return `#f~.")))
\ No newline at end of file
diff --git a/mcgoron.cond-thunk.srfi.210.compat.sld b/mcgoron.cond-thunk.srfi.210.compat.sld
new file mode 100644
index 0000000..2d6bb98
--- /dev/null
+++ b/mcgoron.cond-thunk.srfi.210.compat.sld
@@ -0,0 +1,26 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | 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 (mcgoron cond-thunk srfi 210 compat)
+  (import (scheme base) (scheme case-lambda))
+  (export case-receive)
+  (begin
+    (define-syntax case-receive
+      (syntax-rules ()
+        ((case-receive producer clauses ...)
+         (call-with-values (lambda () producer)
+           (case-lambda clauses ...)))))))
+
diff --git a/mcgoron.cond-thunk.values.scm b/mcgoron.cond-thunk.values.scm
new file mode 100644
index 0000000..ca4469a
--- /dev/null
+++ b/mcgoron.cond-thunk.values.scm
@@ -0,0 +1,76 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | 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-syntax cond-values
+  (syntax-rules (else)
+    ((cond-values clauses ... (else body ...))
+     (cond-thunk clauses ... (else body ...)))
+    ((cond-values clauses ...)
+     (cond-thunk clauses ... (else (values))))))
+
+(define-syntax after
+  (syntax-rules (when let =>)
+    ((after ((when conditional) clauses ...) body ...)
+     (if conditional
+         (after (clauses ...) body ...)
+         #f))
+    ((after ((let value => formal) clauses ...) body ...)
+     (case-receive value
+       (() #f)
+       (formal (after (clauses ...) body ...))))
+    ((after () body ...)
+     (lambda () body ...))))
+
+(define-syntax apply-after
+  (syntax-rules ()
+    ((apply-after producer consumer)
+     (after ((let producer => formal))
+       (apply consumer formal)))))
+
+(define (pair=> x)
+  (cond-values
+    (after ((when (pair? x)))
+      (values (car x) (cdr x)))))
+
+(define (list-length-destructor whole-list num final-call)
+  (cond-thunk
+    (when-ct (not (integer? num))
+      (error "must be integer" num))
+    (when-ct (not (positive? num))
+      (error "must be positive" num))
+    (else
+     (let loop ((iterator whole-list)
+                (collected '())
+                (num num))
+       (cond-values
+         (after ((when (= num 0)))
+           (final-call collected iterator))
+         (after ((let (pair=> iterator) => (head rest)))
+           (loop (cdr rest) (cons head collected) (- num 1))))))))
+
+(define (length-at-least=> whole-list num)
+  (list-length-destructor whole-list num
+                          (lambda (reverse-seen rest)
+                            (when-ct (or (null? rest) (pair? rest))
+                              (apply values
+                                     (reverse (cons rest reverse-seen)))))))
+
+(define (length=> whole-list num)
+  (list-length-destructor whole-list num
+                          (lambda (_ rest)
+                            (when-ct (null? rest)
+                              (apply values whole-list)))))
+
diff --git a/mcgoron.cond-thunk.values.sld b/mcgoron.cond-thunk.values.sld
new file mode 100644
index 0000000..55f5b22
--- /dev/null
+++ b/mcgoron.cond-thunk.values.sld
@@ -0,0 +1,27 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | 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 (mcgoron cond-thunk values)
+  (import (scheme base) (mcgoron cond-thunk))
+  (export after apply-after
+          cond-values
+          pair=>
+          length-at-least=> length=>)
+  (cond-expand
+   (chicken (import (mcgoron cond-thunk srfi 210 compat)))
+   (else (import (srfi 210))))
+  (include "mcgoron.cond-thunk.values.scm"))
+
diff --git a/test/cas.scm b/test/cas.scm
new file mode 100644
index 0000000..5d87632
--- /dev/null
+++ b/test/cas.scm
@@ -0,0 +1,66 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | 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.
+ |#
+
+(cond-expand
+ (chicken (import test r7rs))
+ (else (import (srfi 64))))
+
+(load "../mcgoron.cond-thunk.srfi.210.compat.sld")
+(load "../mcgoron.cond-thunk.sld")
+(load "../mcgoron.cond-thunk.values.sld")
+(import (mcgoron cond-thunk) (mcgoron cond-thunk values) (srfi 1))
+
+(define function=> pair=>)
+
+(define (mult=> form)
+  (cond-values
+    (after ((let (function=> form) => (head tail))
+        (when (eq? head '*)))
+      tail)))
+
+(define (add=> form)
+  (cond-values
+    (after ((let (function=> form) => (head tail))
+        (when (eq? head '+)))
+      tail)))
+
+(define (add? form)
+  (cond-thunk
+    (after ((let (add=> form) => (_)))
+      #t)
+    (else #f)))
+
+(define (distribute form)
+  (cond-thunk
+    (after ((let (mult=> form) => (arguments)))
+      (let-values (((add others) (partition add? arguments)))
+        ;; ADD is a list of addition clauses.
+        (let ((added-values (concatenate (map cdr add))))
+          (cons '+
+                (map (lambda (added-value)
+                       (cons* '*
+                              (distribute added-value)
+                              others))
+                     added-values)))))
+    (after ((let (function=> form) => (head arguments)))
+      (cons head (map distribute arguments)))
+    (else form)))
+
+(test
+ "distribute1"
+ '(+ (* y x) (* z x))
+ (distribute '(* x (+ y z))))
+