;seqprocs.scm
;SLaTeX v. 2.3
;Sequence routines
;(c) Dorai Sitaram, Rice U., 1991, 1994

;But first, let's open a new namespace for symbols
;local to the SLaTeX implementation code

(module SLaTeX.)

(local ormap ormapcdr append! append-map! remove-if!
  reverse! list-set! list-prefix? string-prefix? string-suffix?
  member-string adjoin-string remove-string! adjoin-char
  remove-char! sublist position-char string-position-right
  token=?
  assoc-token member-token
  remove-token!)

(extract-if (chez)
  (define ormap (global$ ormap)))

(extract-if (cl)
  (define ormap some))

(extract-if (cscheme)
    (define ormap (lambda (f l) (there-exists? l f))))

(extract-if-not (chez cl cscheme)
  (define ormap
    (lambda (f l)
      ;;returns nonfalse iff f is true of at least one element in l;
      ;;this nonfalse value is that given by the first such element in l;
      ;;only one argument list supported
      (let loop ((l l))
	(if (null? l) #f
	  (or (f (car l)) (loop (cdr l))))))))

(define ormapcdr
  (lambda (f l)
    ;;returns the first cdr of l for which f is true;
    ;;only one argument list supported
    (let loop ((l l))
      (if (null? l) #f
        (or (funcall f l) (loop (cdr l)))))))

(extract-if (cl)
  (define append! nconc))

(extract-if (chez cscheme elk pcsge)
  (define append! (global$ append!)))

(extract-if-not (chez cl cscheme elk pcsge)
  (define append!
    (lambda (l1 l2)
      ;;destructively appends lists l1 and l2;
      ;;only two argument lists supported
      (cond ((null? l1) l2)
	    ((null? l2) l1)
	    (else (let loop ((l1 l1))
		    (if (null? (cdr l1))
			(set-cdr! l1 l2)
			(loop (cdr l1))))
		  l1)))))

(extract-if (cscheme)
    (define append-map! (global$ append-map!)))

(extract-if (cl)
    (define append-map! mapcan))

(extract-if-not (cl cscheme)
  (define append-map!
    (lambda (f l)
      ;;maps f on l but splices (destructively) the results;
      ;;only one argument list supported
      (let loop ((l l))
	(if (null? l) '()
	  (append! (f (car l)) (loop (cdr l))))))))

(extract-if (cl)
  (define remove-if! delete-if))

(extract-if (chez)
  (define remove-if! rem!))

(extract-if-not (chez cl)
  (define remove-if!
    (lambda (p s)
      ;;removes those elts of list s that satisfy p;
      ;;destructive on s
      (let loop ((s s))
	(cond ((null? s) '())
	      ((p (car s)) (loop (cdr s)))
	      (else (let ((r (loop (cdr s))))
		      (set-cdr! s r)
		      s)))))))

'(extract-if-not (chez cl)
  (define remove-if!
    (lambda (? s)
      ;;old version of above
      (let ((headed-s (cons 'void s)))
        (let loop ((s s) (trail headed-s))
          (if (null? s) (cdr headed-s)
            (let ((a (car s)))
              (if (? a)
                  (let ((d (cdr s)))
                    (set-cdr! trail d)
                    (loop d trail))
                  (loop (cdr s) s)))))))))

(extract-if (cl)
    (define reverse! nreverse))

(extract-if (chez cscheme elk pcsge)
  (define reverse! (global$ reverse!)))

(extract-if-not (chez cl cscheme elk pcsge)
  (define reverse!
    (lambda (s)
      ;;reverses list s inplace (i.e., destructively)
      (let loop ((s s) (r '()))
	(if (null? s) r
	  (let ((d (cdr s)))
	    (set-cdr! s r)
	    (loop d s)))))))

(extract-if-not (cl)
  (define list-set!
    (lambda (l i v)
    ;sets the i-th element of list l to v
      (let loop ((l l) (i i))
	(cond ((null? l) (error 'list-set! 'list-too-small))
	      ((= i 0) (set-car! l v))
	      (else (loop (cdr l) (- i 1))))))))

(define list-prefix?
  (lambda (pfx l)
    ;;tests if list pfx is a prefix of list l
    (cond ((null? pfx) #t)
	  ((null? l) #f)
	  ((eqv? (car pfx) (car l)) (list-prefix? (cdr pfx) (cdr l)))
	  (else #f))))

(define string-prefix?
  (lambda (pfx s)
    ;;tests if string pfx is a prefix of string s
    (let ((pfx-len (string-length pfx)) (s-len (string-length s)))
      (if (> pfx-len s-len) #f
	(let loop ((i 0))
	  (if (>= i pfx-len) #t
	    (and (char=? (string-ref pfx i) (string-ref s i))
	      (loop (+ i 1)))))))))

(define string-suffix?
  (lambda (sfx s)
    ;;tests if string sfx is a suffix of string s
    (let ((sfx-len (string-length sfx)) (s-len (string-length s)))
      (if (> sfx-len s-len) #f
	(let loop ((i (- sfx-len 1)) (j (- s-len 1)))
	  (if (< i 0) #t
	    (and (char=? (string-ref sfx i) (string-ref s j))
	      (loop (- i 1) (- j 1)))))))))

(define member-string member)

(extract-if (cl)
  (define adjoin-string
    (lambda (s l)
      (adjoin s l :test string=?))))

(extract-if-not (cl)
  (define adjoin-string
    (lambda (s l)
      ;;adjoins string s to string-set l
      (if (member-string s l) l
	(cons s l)))))

(extract-if (cl)
  (define remove-string!
    (lambda (s l)
      (delete s l :test string=?))))

(extract-if (chez schemetoc)
    (define remove-string! remove!))

(extract-if-not (chez cl schemetoc)
  (define remove-string!
    (lambda (s l)
      ;;destructively removes string s from string-set l
      (remove-if! (lambda (l_i) (string=? l_i s)) l))))

(extract-if (cl)
  (define adjoin-char
    (lambda (c l)
      (adjoin c l :test char=?))))

(extract-if-not (cl)
  (define adjoin-char
    (lambda (c l)
    ;adjoins char c to a char-set l
      (if (memv c l) l (cons c l)))))

(extract-if (cl)
  (define remove-char!
    (lambda (c l)
      (delete c l :test char=?))))

(extract-if (chez schemetoc)
    (define remove-char! remv!))

(extract-if-not (chez cl schemetoc)
  (define remove-char!
    (lambda (c l)
      ;;destructively removes char c from char-set l
      (remove-if! (lambda (l_i) (char=? l_i c)) l))))

(extract-if (cl)
  (define sublist subseq))

(extract-if-not (cl)
  (define sublist
    (lambda (l i f)
      ;;finds the sublist of l from index i inclusive to index f exclusive
      (let loop ((l (list-tail l i)) (k i) (r '()))
        (cond ((>= k f) (reverse! r))
              ((null? l) (error 'sublist 'list-too-small))
              (else (loop (cdr l) (+ k 1) (cons (car l) r))))))))

(extract-if (cl)
    (define position-char position))

(extract-if-not (cl)
  (define position-char
    (lambda (c l)
      ;;finds the leftmost index of character-list l where character c occurs
      (let loop ((l l) (i 0))
	(cond ((null? l) #f)
	      ((char=? (car l) c) i)
	      (else (loop (cdr l) (+ i 1))))))))

(extract-if (cl)
  (define string-position-right
    (lambda (c s)
      (position c s :test char=? :from-end #t))))

(extract-if-not (cl)
  (define string-position-right
    (lambda (c s)
    ;;finds the rightmost index of string s where character c occurs
      (let ((n (string-length s)))
	(let loop ((i (- n 1)))
	  (cond ((< i 0) #f)
		((char=? (string-ref s i) c) i)
		(else (loop (- i 1)))))))))

(extract-if (cl)
  (define assoc-token
    (lambda (x s)
      (cl/assoc x s :test token=?))))

(extract-if-not (cl)
  (define assoc-token
    (lambda (x s)
      ;;finds cell corresponding to token x in alist s
      (ormap (lambda (s_i) (if (token=? (car s_i) x) s_i #f)) s))))

(extract-if (cl)
  (define member-token
    (lambda (x s)
      (cl/member x s :test token=?))))

(extract-if-not (cl)
  (define member-token
    (lambda (x s)
    ;;finds tail of list s starting with token x
      (ormapcdr (lambda (s_i..) (if (token=? (car s_i..) x) s_i.. #f))
	s))))

(extract-if (cl)
  (define remove-token!
    (lambda (x s)
      (delete x s :test token=?))))

(extract-if-not (cl)
  (define remove-token!
    (lambda (x s)
      ;;removes token x destructively from token-list s
      (remove-if! (lambda (s_i) (token=? s_i x)) s))))