values lib

1 files changed, 76 insertions, 0 deletions

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