Guile-hoot/lib/srfi/srfi-1.scm

;;; SRFI-1
;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;;
;;; 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.

;;; Commentary:
;;;
;;; SRFI-1: List Library
;;;
;;; This module is temporary, containing just the things we need right
;;; now, until we are able to import and compile Guile's SRFI-1.
;;;
;;; Code:
(define-module (srfi srfi-1)
  #:use-module ((hoot lists) #:select (alist-cons fold))
  #:export (any1
            any
            every1
            every
            fold-right
            filter-map
            find)
  #:re-export ((acons . alist-cons)
               fold
               iota))

(define (fold-right f seed l)
  (fold f seed (reverse l)))

(define reverse! reverse)

(define (any1 pred ls)
  "Return the first non-false value returned by applying @var{pred} to the
elements of @var{ls}, or @code{#f}."
  (let lp ((ls ls))
    (cond ((null? ls)
	   #f)
	  ((null? (cdr ls))
	   (pred (car ls)))
	  (else
	   (or (pred (car ls)) (lp (cdr ls)))))))

(define (any pred lst . lsts)
  "Return the first non-false value returned by applying @var{pred} to the
elements of @var{lst} and @var{lsts}, or @code{#f}."
  (if (null? lsts) (any1 pred lst)
      (let lp ((ls (cons lst lsts)))
        (cond
         ((any1 null? ls) #f)
         ((any1 null? (map cdr ls))
          (apply pred (map car ls)))
         (else
          (or (apply pred (map car ls))
              (lp (map cdr ls))))))))

(define (every1 pred lst)
  "Return the value of @var{pred} applied to the last element of @var{lst} if
all other elements of the list satisfy @var{pred}; otherwise return @code{#f}.
Return @code{#t} if @var{lst} is empty."
  (let lp ((l lst))
    (cond
     ((null? l) #t)
     ((null? (cdr l)) (pred (car l)))
     (else
      (and (pred (car l)) (lp (cdr l)))))))

(define (every pred lst . lsts)
  "Return the value of @var{pred} applied to the last elements of @var{lst} and
@var{lsts} if all other elements of the lists satisfy @var{pred}; other return
@code{#f}.  Return @code{#t} if any lists are empty."
  (if (null? lsts) (every1 pred lst)
      (let lp ((ls (cons lst lsts)))
        (cond
         ((any1 null? ls) #t)
         ((any1 null? (map cdr ls))
          (apply pred (map car ls)))
         (else
          (and (apply pred (map car ls))
               (lp (map cdr ls))))))))

(define (find pred lst)
  "Return the first element of @var{lst} that satisfies the predicate
@var{pred}, or return @code{#f} if no such element is found."
  (let loop ((lst lst))
    (and (not (null? lst))
         (let ((head (car lst)))
           (if (pred head)
               head
               (loop (cdr lst)))))))

(define (filter-map proc list1 . rest)
  "Apply PROC to the elements of LIST1... and return a list of the
results as per SRFI-1 `map', except that any #f results are omitted from
the list returned."
  (if (null? rest)
      (let lp ((l list1)
               (rl '()))
        (if (null? l)
            (reverse! rl)
            (let ((res (proc (car l))))
              (if res
                  (lp (cdr l) (cons res rl))
                  (lp (cdr l) rl)))))
      (let lp ((l (cons list1 rest))
               (rl '()))
        (if (any1 null? l)
            (reverse! rl)
            (let ((res (apply proc (map car l))))
              (if res
                  (lp (map cdr l) (cons res rl))
                  (lp (map cdr l) rl)))))))