1;;; -*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Fonts:(CPTFONT CPTFONTB); Base:10. -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.

;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*

;;; DRH notes:
;;;  1) It is an error to call any of these functions with a cyclic list. This is purely for performance reasons.
;;;     If you want to use cyclic lists, use mapcar and friends. 
;;;  2) the length of the resultant sequence is computed in advance.

(EVAL-WHEN (compile)

  (DEFMACRO COMPUTE-MIN-SEQUENCE-LENGTH (list-of-sequences)
1    ;;; given a list of zero or more sequences, this procedure returns the length of the shortest sequence
    ;;; An error occurs if some element of <list-of-sequences> is not a sequence.*
    `(LET ((min (LENGTH (CAR ,list-of-sequences))))
      (DOLIST (s (CDR ,list-of-sequences) min)
	(SETQ min (MIN min (LENGTH s))))))

  (DEFMACRO GET-NEXT-SEQUENCE-ELEMENT (seq index)    ;; could simply be (elt seq index)
    `(IF (ARRAYP ,seq) (AREF ,seq ,index) (POP ,seq)))

;;;    seq1    s11 s12 s13 ... s1n
;;;    seq2    s21 s22 s23 ...
;;;    ...
;;;    seqM    sM1 sM2 sM3 ...
;;;   column=>  0   1   2  ... n-1

  (DEFMACRO APPLY-FCT-TO-COLUMN (fct sequences index number-of-sequences)
    `(DO ((u ,sequences (CDR u)))
	 ((ENDP u) (%CALL ,fct ,number-of-sequences))
       (%PUSH (GET-NEXT-SEQUENCE-ELEMENT (CAR u) ,index))))

  )



(DEFUN MAP (result-type fcn &REST sequences)
  1"Maps over successive elements of each SEQUENCE, returns a sequence of the results.
FCN is called first on the 0'th elements of all the sequences,
then on the 1st elements of all, and so on until some argument sequence is exhausted.
The values returned by FCN are put into a result sequence which is returned by MAP.
RESULT-TYPE is a sequence type; the result is of that type.
Or RESULT-TYPE can be NIL, meaning call FCN for effect only,
throw away the values, and return NIL."*

  (UNLESS sequences (RETURN-FROM MAP nil))      ;;; if no sequences, then exit
  (LET ((number-of-args (LENGTH sequences))
	(result-length (COMPUTE-MIN-SEQUENCE-LENGTH sequences)))
    ;; <return-length> is the length of the shortest sequence in <sequences>
    
    (WHEN (ZEROP result-length)                 ;;; If some sequence has length 0, return fast.
      (RETURN-FROM MAP (IF result-type (MAKE-SEQUENCE result-type 0) nil)))
    (%ASSURE-PDL-ROOM (+ number-of-args 4))	;;; make sure %PUSH's don't lose
    (IF result-type
	(LET* ((result (MAKE-SEQUENCE result-type result-length)))
	  (IF (LISTP result)
	      ;; if <result> is a list, then CDR-down <result> replacing the i-th element with the
	      ;;   result of applying <fcn> to the i-th element of each sequence
	      (DO ((res result (CDR res))
		   (index 0 (1+ index)))     ;; use <index> to traverse any seuqnces which are arrays
		  ((NULL res) result)        
		(SETF (CAR res)
		      (DO ((seqlist sequences (CDR seqlist)))   ;; push the i-th element of each sequence onto the stack
			  ((NULL seqlist) (%CALL fcn number-of-args))   ;; when done, call the function.
			(%PUSH (IF (ARRAYP (CAR seqlist)) (AREF (CAR seqlist) index)
				   (POP (CAR seqlist)))))))
	      ;; else <result> is an array of some sort.
	      (DOTIMES (index result-length result)   
		(SETF (AREF result index)
		      (DO ((seqlist sequences (CDR seqlist)))
			  ((NULL seqlist) (%CALL fcn number-of-args))
			(%PUSH (IF (ARRAYP (CAR seqlist)) (AREF (CAR seqlist) index)
				   (POP (CAR seqlist)))))))))
	;;  <result-type> unspecified -- just call <fcn> for effect
	(DO ((index 0 (1+ index)))
	    ((= index result-length) nil) 
	  (DO ((seqlist sequences (CDR seqlist)))
	      ((NULL seqlist) (%CALL fcn number-of-args))
	    (%PUSH (IF (ARRAYP (CAR seqlist)) (AREF (CAR seqlist) index)
		       (POP (CAR seqlist)))))))))


(DEFUN SOME (predicate &REST sequences)
  1"Applies <predicate> to successive elements of <sequences> and
returns non-NIL if <predicate> returns non-NIL for some application.
 <predicate> gets one argument from each sequence; 
first element 0 of each sequence, then element 1, and so on.
If some application of <predicate> returns non-NIL, then the value
it returns is returned by SOME.
When one of the sequences is exhausted, SOME returns NIL."*

  (LET ((number-of-args (LENGTH sequences))
	(length (COMPUTE-MIN-SEQUENCE-LENGTH sequences)))
    ;; <length> is the length of the shortest sequence in <sequences>

    (%ASSURE-PDL-ROOM (+ number-of-args 4))
    (DO ((index 0 (1+ index))
	 ans)
	((= index length) nil)
      (WHEN (SETQ ans (APPLY-FCT-TO-COLUMN predicate sequences index number-of-args))
	(RETURN-FROM SOME ans)))))

(DEFUN NOTEVERY (predicate &REST sequences)
  1"Applies <predicate> to successive elements of <sequences> and
returns T if <predicate> returns NIL for some application.
 <predicate> gets one argument from each sequence; 
first element 0 of each sequence, then element 1, and so on.
If some application of <predicate> returns NIL, NOTEVERY returns T.
When one of the sequences is exhausted, NOTEVERY returns NIL."*

  (LET ((number-of-args (LENGTH sequences))
	(length (COMPUTE-MIN-SEQUENCE-LENGTH sequences)))
    ;; <length> is the length of the shortest sequence in <sequences>

    (%ASSURE-PDL-ROOM (+ number-of-args 4))
    (DO ((index 0 (1+ index))
	 ans)
	((= index length) nil)
      (UNLESS (SETQ ans (APPLY-FCT-TO-COLUMN predicate sequences index number-of-args))
	(RETURN-FROM NOTEVERY T)))))



(DEFUN NOTANY (predicate &REST sequences)
  1"Applies <predicate> to successive elements of <sequences> and
returns T if <predicate> returns NIL for all applications.
 <predicate> gets one argument from each sequence; 
first element 0 of each sequence, then element 1, and so on.
If some application of <predicate> returns non-NIL, NOTANY returns NIL.
When one of the sequences is exhausted, NOTANY returns T."*

  (LET ((number-of-args (LENGTH sequences))
	(length (COMPUTE-MIN-SEQUENCE-LENGTH sequences)))
    ;; <length> is the length of the shortest sequence in <sequences>

    (%ASSURE-PDL-ROOM (+ number-of-args 4))
    (DO ((index 0 (1+ index)))
	((= index length) T) 
      (WHEN (APPLY-FCT-TO-COLUMN predicate sequences index number-of-args)
	(RETURN-FROM NOTANY nil)))))

(DEFUN EVERY (predicate &REST sequences)
  1"Applies <predicate> to successive elements of <sequences> and
returns T unless <predicate> returns NIL for some application.
 <predicate> gets one argument from each sequence; 
first element 0 of each sequence, then element 1, and so on.
If some application of <predicate> returns NIL, EVERY returns nil.
When one of the sequences is exhausted, EVERY returns T."*

  (LET ((number-of-args (LENGTH sequences))
	(length (COMPUTE-MIN-SEQUENCE-LENGTH sequences)))
    ;; <length> is the length of the shortest sequence in <sequences>

    (%ASSURE-PDL-ROOM (+ number-of-args 4))
    (DO ((index 0 (1+ index)))
	((= index length) T) 
      (UNLESS (APPLY-FCT-TO-COLUMN predicate sequences index number-of-args)
	(RETURN-FROM EVERY nil)))))