peter
/
cond-values
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

factor into libraries

This commit is contained in:
Peter McGoron 2024-10-18 12:48:01 -04:00
parent e52009c0a2
commit 13c68fc3fa
4 changed files with 81 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
cond-values.scm → cond-values-impl.scm
View File

@ -11,8 +11,6 @@
;;; implied. See the License for the specific language governing
;;; permissions and limitations under the License.
(import srfi-1)
;;; AFTER executes a body after multiple tests.
;;;
;;; The form of the syntax is
@ -159,29 +157,3 @@
(after ((when (> num 0))
(when (pair? lst)))
(length-at-least (cdr lst) (- num 1))))))
;;; Helper function.
(define (null-cdr? lst) (null? (cdr lst)))
;;; MAP-VALUES returns (VALUES L1 L2 ...), where L1 is the first
;;; value returned from (F (CAR LST)), (F (CADR LST)), ... and so on.
(define (map-values f . lists)
(define (null-cdr? lst) (null? (cdr lst)))
(let-values ((new-values (apply f (map car lists))))
(if (any null-cdr? lists)
(apply values (map list new-values))
(let-values ((returned (apply map-values f (map cdr lists))))
(apply values (map cons new-values returned))))))
;;; (ANY-VALUES F (A1 A2 ...) (B1 B2 ...) ...) runs
;;; (F A1 B1 ...) and checks if there any returned values. If there are
;;; none, runs (F A2 B2 ...), and so on.
;;;
;;; If any of the lists end, then ANY-VALUES returns no values.
(define (any-values f . lists)
(after ((when (not (null? lists)))
(when (all pair? lists)))
(let-values ((returned (apply f (map car lists))))
(if (null? returned)
(apply any-values f (map cdr lists))
(apply values returned)))))

23
cond-values.r7rs.scm Normal file
View File

@ -0,0 +1,23 @@
;;; 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 r7rs)))
(define-library (mcgoron.com cond-values)
(import (scheme base))
(export after cond-values
define-record-type/destructor
pair-d assq-d
length* length-at-least)
(import "cond-values.scm"))

20
values-lib.r7rs.scm Normal file
View File

@ -0,0 +1,20 @@
;;; 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 r7rs)))
(define-library (mcgoron.com values-lib)
(import (scheme base) srfi-1)
(export map-values any-values)
(import "values-lib.scm"))

38
values-lib.scm Normal file
View File

@ -0,0 +1,38 @@
;;; 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.
;;; Helper function.
(define (null-cdr? lst) (null? (cdr lst)))
;;; MAP-VALUES returns (VALUES L1 L2 ...), where L1 is the first
;;; value returned from (F (CAR LST)), (F (CADR LST)), ... and so on.
(define (map-values f . lists)
(define (null-cdr? lst) (null? (cdr lst)))
(let-values ((new-values (apply f (map car lists))))
(if (any null-cdr? lists)
(apply values (map list new-values))
(let-values ((returned (apply map-values f (map cdr lists))))
(apply values (map cons new-values returned))))))
;;; (ANY-VALUES F (A1 A2 ...) (B1 B2 ...) ...) runs
;;; (F A1 B1 ...) and checks if there any returned values. If there are
;;; none, runs (F A2 B2 ...), and so on.
;;;
;;; If any of the lists end, then ANY-VALUES returns no values.
(define (any-values f . lists)
(after ((when (not (null? lists)))
(when (all pair? lists)))
(let-values ((returned (apply f (map car lists))))
(if (null? returned)
(apply any-values f (map cdr lists))
(apply values returned)))))