#| 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-thunk
  (syntax-rules (else)
    ((cond-thunk expr ... (else body ...))
     (cond
       (expr => (lambda (x) (x)))
       ...
       (else body ...)))
    ((cond-thunk expr ...)
     (cond-thunk expr ... (else #f)))))

(define any-thunk
  (letrec ((loop
            (lambda (thunks else-thunk)
              (if (null? thunks)
                  (else-thunk)
                  (let* ((thunk (car thunks))
                         (result (thunk)))
                    (if (not result)
                        (loop (cdr thunks))
                        (result)))))))
    (case-lambda
      ((thunks) (loop thunks (lambda () #f)))
      ((thunks else-thunk) (loop thunks else-thunk)))))

(define-syntax when-ct
  (syntax-rules ()
    ((when-ct conditional body ...)
     (if conditional
         (lambda () body ...)
         #f))))

(define-syntax lambda-ct
  (syntax-rules ()
    ((lambda-ct formal conditional body ...)
     (lambda formal (when-ct conditional body ...)))))

(define-syntax define-ct
  (syntax-rules ()
    ((define-ct (name . formal) conditional body ...)
     (define name
       (lambda-ct formal conditional body ...)))))