; $Id: list.scm,v 1.24 2009-12-10 23:05:20 logik Exp $
; 1. Preliminaries
; ================

(define (list-head list k)
  (do ((l list (cdr l))
       (n 0 (+ n 1))
       (res '() (cons (car l) res)))
      ((= n k) (reverse res))))

(define (zip list1 list2)
  (do ((l1 list1 (cdr l1))
       (l2 list2 (cdr l2))
       (res '() (cons (car l2) (cons (car l1) res))))
      ((or (null? l1) (null? l2))
       (if (null? l1)
	   (if (null? l2)
	       (reverse res)
	       (append (reverse res) l2))
	   (append (reverse res) l1)))))

; (zip '(1 3 5 ) '(2 4 6 ))
; (1 2 3 4 5 6)

(define (remove x list)
  (do ((l list (cdr l))
       (res '() (if (equal? x (car l))
                    res
                    (cons (car l) res))))
      ((null? l) (reverse res))))

(define (adjoin x list) (if (member x list) list (cons x list)))

(define (remove-duplicates list)
  (do ((l list (cdr l))
       (res '() (if (member (car l) res)
                    res
                    (cons (car l) res))))
      ((null? l) (reverse res))))

(define (remove-common-head list1 list2)
  (if (and (pair? list1) (pair? list2) (equal? (car list1) (car list2)))
      (remove-common-head (cdr list1) (cdr list2))
      (list list1 list2)))

(define (remove-common-tail list1 list2)
  (let ((aux (remove-common-head (reverse list1) (reverse list2))))
    (list (reverse (car aux)) (reverse (cadr aux)))))

(define (union . x)
  (cond ((null? x) '())
	((list? (car x))
	 (remove-duplicates (append (car x) (apply union (cdr x)))))
	(else (myerror "union: list expected" (car x)))))

(define (intersection . x)
  (cond ((null? x)
	 (myerror "intersection should have at least one argument"))
	((list? (car x))
	 (if (null? (cdr x))
	     (car x)
	     (do ((list (apply intersection (cdr x)) (cdr list))
		  (res '() (if (member (car list) (car x))
			       (cons (car list) res)
			       res)))
		 ((null? list) (reverse res)))))
	(else (myerror "intersection: list expected" (car x)))))

(define (multiset-intersection-2 list1 list2)
  (do ((l1 list1 (cdr l1))
       (l2 list2 (if (member (car l1) l2)
                     (multiset-remove (car l1) l2)
                     l2))
       (res '() (if (member (car l1) l2)
                    (cons (car l1) res)
                    res)))
      ((or (null? l1) (null? l2)) (reverse res))))

(define (set-minus list1 list2)
  (do ((l list2 (cdr l))
       (res list1 (remove (car l) res)))
      ((null? l) res)))

(define (set-closure init-list closure-op)
  (do ((lists `(,(closure-op init-list) ,init-list)
	      (cons (closure-op (car lists)) lists)))
      ((null? (set-minus (car lists) (cadr lists)))
       (car lists))))

(define (multiset-remove x y)
  (do ((l y (cdr l))
       (res-and-flag (list '() #t)
                     (let ((res (car res-and-flag))
                           (flag (cadr res-and-flag)))
                       (if (and flag (equal? x (car l)))
                           (list res #f)
                           (list (cons (car l) res) flag)))))
      ((null? l) (reverse (car res-and-flag)))))

(define (multiset-intersection . x)
  (cond ((null? x)
	 (myerror "multiset-intersection should have at least one argument"))
	((list? (car x))
	 (if (null? (cdr x))
	     (car x)
	     (do ((l1 (car x) (cdr l1))
		  (l2 (apply multiset-intersection (cdr x))
		      (if (member (car l1) l2)
			  (multiset-remove (car l1) l2)
			  l2))
		  (res '() (if (member (car l1) l2)
			       (cons (car l1) res)
			       res)))
		 ((or (null? l1) (null? l2)) (reverse res)))))
	(else
	 (myerror "multiset-intersection: list expected" (car x)))))

(define (multiset-minus list1 list2)
  (do ((l list2 (cdr l))
       (res list1 (multiset-remove (car l) res)))
      ((null? l) res)))

(define (multiset-equal? list1 list2)
  (let multiset-equal?-aux ((l1 list1) (l2 list2))
    (cond ((null? l1) (null? l2))
	  ((member (car l1) l2)
	   (multiset-equal?-aux (cdr l1) (multiset-remove (car l1) l2)))
	  (else #f))))

; We now relativize these (and other) procedures to a given equality:

(define (assoc-wrt equality? x alist)
  (cond ((null? alist) #f)
        ((equality? x (caar alist)) (car alist))
        (else (assoc-wrt equality? x (cdr alist)))))

(define (member-wrt equality? x list)
  (cond ((null? list) #f)
        ((equality? x (car list)) list)
        (else (member-wrt equality? x (cdr list)))))

(define (remove-wrt equality? x list)
  (do ((l list (cdr l))
       (res '() (if (equality? x (car l))
                    res
                    (cons (car l) res))))
      ((null? l) (reverse res))))

; (define (remq x list) (remove-wrt eq? x list))
; Already a global variable (detected by Bigloo)

(define (remv x list) (remove-wrt eqv? x list))

(define (adjoin-wrt equality? x list)
  (if (member-wrt equality? x list) list (cons x list)))

(define (remove-duplicates-wrt equality? list)
  (do ((l list (cdr l))
       (res '() (if (member-wrt equality? (car l) res)
                    res
                    (cons (car l) res))))
      ((null? l) (reverse res))))

(define (remq-duplicates list) (remove-duplicates-wrt eq? list))
(define (remv-duplicates list) (remove-duplicates-wrt eqv? list))

; (duplicates-wrt equality? l) returns a list of two-element sublists
; (x x') of equal elements of l whose transitive closure consists of
; all such two-element sublists.

(define (duplicates-wrt equality? l)
  (if (null? l) '()
      (let* ((x (car l))
	     (xs (cdr l))
	     (duplicates-of-x-in-xs
	      (list-transform-positive xs
		(lambda (item) (equality? x item))))
	     (prev (duplicates-wrt equality? xs)))
	(if (null? duplicates-of-x-in-xs)
	    prev
	    (cons (list x (car duplicates-of-x-in-xs)) prev)))))

(define (union-wrt equality? . x)
  (cond ((null? x) '())
	((list? (car x))
	 (remove-duplicates-wrt
	  equality?
	  (append (car x) (apply union-wrt (cons equality? (cdr x))))))
	(else (myerror "union-wrt: list expected" (car x)))))

(define (unionq . x) (apply union-wrt (cons eq? x)))
(define (unionv . x) (apply union-wrt (cons eqv? x)))

(define (intersection-wrt equality? . x)
  (cond ((null? x)
	 (myerror "intersection-wrt should have at least one argument"))
	((list? (car x))
	 (if (null? (cdr x))
	     (car x)
	     (do ((list (apply intersection-wrt (cons equality? (cdr x)))
			(cdr list))
		  (res '() (if (member-wrt equality? (car list) (car x))
			       (cons (car list) res)
			       res)))
		 ((null? list) (reverse res)))))
	(else (myerror "intersection-wrt: list expected" (car x)))))

(define (intersecq . x) (apply intersection-wrt (cons eq? x)))
(define (intersecv . x) (apply intersection-wrt (cons eqv? x)))

(define (set-minus-wrt equality? list1 list2)
  (do ((l list2 (cdr l))
       (res list1 (remove-wrt equality? (car l) res)))
      ((null? l) res)))

(define (set-minq list1 list2) (set-minus-wrt eq? list1 list2))
(define (set-minv list1 list2) (set-minus-wrt eqv? list1 list2))

(define (closure-wrt equality? init-list closure-op)
  (do ((lists `(,(closure-op init-list) ,init-list)
	      (cons (closure-op (car lists)) lists)))
      ((null? (set-minus-wrt equality? (car lists) (cadr lists)))
       (car lists))))

(define (closq init-list closure-op) (closure-wrt eq? init-list closure-op))
(define (closv init-list closure-op) (closure-wrt eqv? init-list closure-op))

(define (multiset-remove-wrt equality? x y)
  (do ((l y (cdr l))
       (res-and-flag (list '() #t)
                     (let ((res (car res-and-flag))
                           (flag (cadr res-and-flag)))
                       (if (and flag (equality? x (car l)))
                           (list res #f)
                           (list (cons (car l) res) flag)))))
      ((null? l) (reverse (car res-and-flag)))))

(define (multiset-remq x y) (multiset-remove-wrt eq? x y))
(define (multiset-remv x y) (multiset-remove-wrt eqv? x y))

(define (multiset-intersection-wrt equality? . x)
  (cond ((null? x)
	 (myerror
	  "multiset-intersection-wrt should have at least one argument"))
	((list? (car x))
	 (if (null? (cdr x))
	     (car x)
	     (do ((l1 (car x) (cdr l1))
		  (l2 (apply multiset-intersection-wrt
			     (cons equality? (cdr x)))
		      (if (member-wrt equality? (car l1) l2)
			  (multiset-remove-wrt equality? (car l1) l2)
			  l2))
		  (res '() (if (member-wrt equality? (car l1) l2)
			       (cons (car l1) res)
			       res)))
		 ((or (null? l1) (null? l2)) (reverse res)))))
	(else (myerror
	       "multiset-intersection-wrt: list expected" (car x)))))

(define (multiset-intersecq . x)
  (apply multiset-intersection-wrt (cons eq? x)))
(define (multiset-intersecv . x)
  (apply multiset-intersection-wrt (cons eqv? x)))

(define (multiset-minus-wrt equality? list1 list2)
  (do ((l list2 (cdr l))
       (res list1 (multiset-remove-wrt equality? (car l) res)))
      ((null? l) res)))

(define (multiset-minq list1 list2) (multiset-minus-wrt eq? list1 list2))
(define (multiset-minv list1 list2) (multiset-minus-wrt eqv? list1 list2))

(define (multiset-equal-wrt? equality? list1 list2)
  (let multiset-equal-wrt-aux ((l1 list1) (l2 list2))
    (cond ((null? l1) (null? l2))
	  ((member-wrt equality? (car l1) l2) 
	   (multiset-equal-wrt-aux
	    (cdr l1) (multiset-remove-wrt equality? (car l1) l2)))
	  (else #f))))

(define (multiset-eq? list1 list2) (multiset-equal-wrt? eq? list1 list2))
(define (multiset-eqv? list1 list2) (multiset-equal-wrt? eqv? list1 list2))

; alist-to-multivalued-alist-wrt transforms ((x1 y1) (x2 y2) ...) into
; ((z1 y11 y12 ...) (z2 y21 y22 ...) ...) with distinct zi's.

(define (alist-to-multivalued-alist-wrt equality? alist)
  (letrec ((insert
	    (lambda (x y alist1)
	      (if (null? alist1)
		  (list (list x y))
		  (let* ((x-and-ys (car alist1))
			 (rest (cdr alist1)))
		    (if (equality? x (car x-and-ys))
			(cons (cons x (cons y (cdr x-and-ys))) rest)
			(cons x-and-ys (insert x y rest))))))))
    (if (null? alist) '()
	(let* ((prev (alist-to-multivalued-alist-wrt equality? (cdr alist)))
	       (x-and-y (car alist))
	       (x (car x-and-y))
	       (y (cadr x-and-y)))
	  (insert x y prev)))))

(define (list-to-left-associated-list x)
  (if (<= (length x) 2)
      x
      (let* ((l (length x))
	     (hd (list-head x (- l 1))))
	(list (list-to-left-associated-list hd) (car (last-pair x))))))

; (list-to-left-associated-list '(0 1 2 3))
; (((0 1) 2) 3)

(define (non-null-list-to-app-expr x)
  (let ((l (length x)))
    (cond ((= 1 l) (car x))
	  ((= 2 l) x)
	  (else (list-to-left-associated-list x)))))

(define (string-downcase string)
  (list->string (map char-downcase (string->list string))))

; Refined display for debugging

(define (display-more . x)
  (for-each display x)
  (newline))

(define (list-transform-positive l test)
  (if (null? l)                         
      l
      (let ((a (car l)))
	(if (test a)
	    (cons a (list-transform-positive (cdr l) test))
	    (list-transform-positive (cdr l) test)))))

(define (list-search-positive l test)
  (if (null? l)                      
      #f
      (let  ((a (car l)))
	(if (test a)
	    a
	    (list-search-positive (cdr l) test)))))

(define and-op
    (lambda  x
      (cond ((null? x) #t)
	    ((car x) (apply and-op (cdr x)))
	    (else #f))))

(define or-op
    (lambda  x
      (cond ((null? x) #f)
	    ((car x) #t)
	    (else (apply or-op (cdr x))))))

(define (remove-final-numeric-chars list-of-chars)
  (if (null? list-of-chars)
      (myerror "remove-final-numeric-chars applied to empty list")
      (do ((l (reverse list-of-chars) (cdr l)))
          ((not (char-numeric? (car l))) (reverse l)))))

(define (remove-final-^ list-of-chars)
  (if (or (null? list-of-chars)
          (not (char=? #\^ (car (reverse list-of-chars)))))
      list-of-chars
      (reverse (cdr (reverse list-of-chars)))))

(define (remove-^ list-of-chars)
  (do ((l list-of-chars (cdr l))
       (res '() (if (char=? #\^ (car l))
                    res
                    (cons (car l) res))))
      ((null? l) (reverse res))))

(define (index-of-first-occurrence x l)
  (let ((x-and-rest (member x l)))
    (if x-and-rest
	(- (length l) (length x-and-rest))
	(myerror "index-of-first-occurrence: element of list expected" x l))))

(define (curry f n)
  (if (= 1 n)
      f
      (lambda (x) (curry (lambda l (apply f (cons x l))) (- n 1)))))

(define (uncurry g n)
  (if (= 1 n)
      g
      (lambda l (apply (uncurry (g (car l)) (- n 1)) (cdr l)))))

; Insertion sort

(define (insert x lt? sorted-list)
  (if (null? sorted-list)
      (list x)
      (let ((fst (car sorted-list)))
	(if (lt? x fst)
	    (cons x sorted-list)
	    (cons fst (insert x lt? (cdr sorted-list)))))))

(define (insertsort lt? l)
  (if (null? l)
      l
      (insert (car l) lt? (insertsort lt? (cdr l)))))

; (insertsort < '(4 2 8 6))
; (insertsort > '(4 2 8 6))

(define (check-all test l)
  (or (null? l)
      (and (test (car l))
	   (check-all test (cdr l)))))

(define (check-exists test l)
  (and (pair? l)
       (or (test (car l))
	   (check-exists test (cdr l)))))
