;;;
;;; <fold.ss> ---- List folds
;;; Time-stamp: <02/02/28 12:02:38 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of SRFI-1.

;;; SRFI-1 is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.

;;; SRFI-1 is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.

;;; You should have received a copy of the GNU Lesser General Public
;;; License along with SRFI-1; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA

;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:

;; Based on the reference implementation by Olin Shiver and hence:

;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
;; this code as long as you do not remove this copyright notice or
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
;;     -Olin

#lang scheme/base

(require srfi/optional
         "predicate.ss"
         "selector.ss"
         "util.ss")

(provide (rename-out [my-map map])
         (rename-out [my-for-each for-each])
         fold
         unfold
         pair-fold
         reduce
         fold-right
         unfold-right
         pair-fold-right
         reduce-right
         append-map
         (rename-out [append-map append-map!])
         (rename-out [my-map map!])
         pair-for-each
         filter-map
         map-in-order)

;; fold/unfold
;;;;;;;;;;;;;;

(define (unfold-right p f g seed . maybe-tail)
  (check-arg procedure? p 'unfold-right)
  (check-arg procedure? f 'unfold-right)
  (check-arg procedure? g 'unfold-right)
  (let lp ((seed seed) (ans maybe-tail))
    (if (p seed) ans
        (lp (g seed)
            (cons (f seed) ans)))))

(define (unfold p f g seed . maybe-tail-gen)
  (check-arg procedure? p 'unfold)
  (check-arg procedure? f 'unfold)
  (check-arg procedure? g 'unfold)
  (if (pair? maybe-tail-gen)
    (let ((tail-gen (car maybe-tail-gen)))
      (if (pair? (cdr maybe-tail-gen))
        (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)
        (let recur ((seed seed))
          (if (p seed) (tail-gen seed)
              (cons (f seed) (recur (g seed)))))))
    (let recur ((seed seed))
      (if (p seed) '()
          (cons (f seed) (recur (g seed)))))))

(define (fold kons knil lis1 . lists)
  (check-arg procedure? kons 'fold)
  (if (pair? lists)
    (let lp ((lists (cons lis1 lists)) (ans knil))   ; N-ary case
      (let-values ([(cars+ans cdrs) (%cars+cdrs+ lists ans)])
        (if (null? cars+ans) ans ; Done.
            (lp cdrs (apply kons cars+ans)))))
    (let lp ((lis lis1) (ans knil))                  ; Fast path
      (if (null-list? lis) ans
          (lp (cdr lis) (kons (car lis) ans))))))

(define (fold-right kons knil lis1 . lists)
  (check-arg procedure? kons 'fold-right)
  (if (pair? lists)
    (let recur ((lists (cons lis1 lists)))        ; N-ary case
      (let ((cdrs (%cdrs lists)))
        (if (null? cdrs) knil
            (apply kons (%cars+ lists (recur cdrs))))))

    (let recur ((lis lis1))                       ; Fast path
      (if (null-list? lis) knil
          (let ((head (car lis)))
            (kons head (recur (cdr lis))))))))

(define (pair-fold-right f zero lis1 . lists)
  (check-arg procedure? f 'pair-fold-right)
  (if (pair? lists)
    (let recur ((lists (cons lis1 lists)))        ; N-ary case
      (let ((cdrs (%cdrs lists)))
        (if (null? cdrs) zero
            (apply f (append lists (list (recur cdrs)))))))
    (let recur ((lis lis1))                       ; Fast path
      (if (null-list? lis) zero (f lis (recur (cdr lis)))))))

(define (pair-fold f zero lis1 . lists)
  (check-arg procedure? f 'pair-fold)
  (if (pair? lists)
    (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case
      (let ((tails (%cdrs lists)))
        (if (null? tails) ans
            (lp tails (apply f (append lists (list ans)))))))
    (let lp ((lis lis1) (ans zero))
      (if (null-list? lis) ans
          (let ((tail (cdr lis)))                  ; Grab the cdr now,
            (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS.

;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
;; These cannot meaningfully be n-ary.

(define (reduce f ridentity lis)
  (check-arg procedure? f 'reduce)
  (if (null-list? lis) ridentity
      (fold f (car lis) (cdr lis))))

(define (reduce-right f ridentity lis)
  (check-arg procedure? f 'reduce-right)
  (if (null-list? lis) ridentity
      (let recur ((head (car lis)) (lis (cdr lis)))
        (if (pair? lis)
          (f head (recur (car lis) (cdr lis)))
          head))))

;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (append-map f lis1 . lists)
  (really-append-map append-map  append  f lis1 lists))
#; ; lists are immutable
(define (append-map! f lis1 . lists)
  (really-append-map append-map! append! f lis1 lists))

(define (really-append-map who appender f lis1 lists)
  (check-arg procedure? f 'who)
  (if (pair? lists)
    (let-values ([(cars cdrs) (%cars+cdrs (cons lis1 lists))])
      (if (null? cars) '()
          (let recur ((cars cars) (cdrs cdrs))
            (let ((vals (apply f cars)))
              (let-values ([(cars2 cdrs2) (%cars+cdrs cdrs)])
                (if (null? cars2) vals
                    (appender vals (recur cars2 cdrs2))))))))
    ;; Fast path
    (if (null-list? lis1) '()
        (let recur ((elt (car lis1)) (rest (cdr lis1)))
          (let ((vals (f elt)))
            (if (null-list? rest) vals
                (appender vals (recur (car rest) (cdr rest)))))))))

(define (pair-for-each proc lis1 . lists)
  (check-arg procedure? proc 'pair-for-each)
  (if (pair? lists)
    (let lp ((lists (cons lis1 lists)))
      (let ((tails (%cdrs lists)))
        (when (pair? tails) (apply proc lists) (lp tails))))
    ;; Fast path.
    (let lp ((lis lis1))
      (unless (null-list? lis)
        (let ((tail (cdr lis))) ; Grab the cdr now,
          (proc lis)            ; in case PROC SET-CDR!s LIS.
          (lp tail))))))

;; We stop when LIS1 runs out, not when any list runs out.
#; ; lists are immutable
(define (map! f lis1 . lists)
  (check-arg procedure? f 'map!)
  (if (pair? lists)
    (let lp ((lis1 lis1) (lists lists))
      (if (not (null-list? lis1))
        (let-values ([(heads tails) (%cars+cdrs/no-test lists)])
          (set-car! lis1 (apply f (car lis1) heads))
          (lp (cdr lis1) tails))))
    ;; Fast path.
    (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
  lis1)

;; Map F across L, and save up all the non-false results.
(define (filter-map f lis1 . lists)
  (check-arg procedure? f 'filter-map)
  (if (pair? lists)
    (let recur ((lists (cons lis1 lists)))
      (let-values ([(cars cdrs) (%cars+cdrs lists)])
        (if (pair? cars)
          (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
                (else (recur cdrs))) ; Tail call in this arm.
          '())))
    ;; Fast path.
    (let recur ((lis lis1))
      (if (null-list? lis) lis
          (let ((tail (recur (cdr lis))))
            (cond ((f (car lis)) => (lambda (x) (cons x tail)))
                  (else tail)))))))

;; Map F across lists, guaranteeing to go left-to-right.
;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
;; in which case this procedure may simply be defined as a synonym for MAP.

(define (map-in-order f lis1 . lists)
  (check-arg procedure? f 'map-in-order)
  (if (pair? lists)
    (let recur ((lists (cons lis1 lists)))
      (let-values ([(cars cdrs) (%cars+cdrs lists)])
        (if (pair? cars)
          (let ((x (apply f cars))) ; Do head first,
            (cons x (recur cdrs)))  ; then tail.
          '())))
    ;; Fast path.
    (let recur ((lis lis1))
      (if (null-list? lis) lis
          (let ((tail (cdr lis))
                (x (f (car lis))))         ; Do head first,
            (cons x (recur tail)))))))     ; then tail.

;; We extend MAP to handle arguments of unequal length.
(define my-map map-in-order)


;;; Apply F across lists, guaranteeing to go left-to-right.
;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
;;; in which case this procedure may simply be defined as a synonym for FOR-EACH.

(define (my-for-each f lis1 . lists)
  (check-arg procedure? f for-each)
  (if (pair? lists)
    (let recur ((lists (cons lis1 lists)))
      (let-values ([(cars cdrs) (%cars+cdrs lists)])
        (when (pair? cars)
          (apply f cars)  ; Do head first,
          (recur cdrs)))) ; then tail.
    ;; Fast path.
    (let recur ((lis lis1))
      (unless (null-list? lis)
        (f (car lis))             ; Do head first,
        (recur (cdr lis))))))

;;; fold.ss ends here
