(use srfi-1) ; partition, append-map, filter-map, ext. member, delete
(use srfi-11) ; let-values

;; tagged lists

(define (tagged? form tag) (and (pair? form) (eq? (car form) tag)))

;; substitution

(define (substitute var expansion template)
  (cond ((equal? var template) expansion)
	((pair? template) (cons (substitute var expansion (car template))
				(substitute var expansion (cdr template))))
	(else template)))

;; equivalence classes

(define (equivalence-classes pairs)
  (if (null? pairs) '()
    (let ((rest-classes (equivalence-classes (cdr pairs))))
      (let-values
	(((eq uneq) (partition (lambda (class)
				 (or (member (caar pairs) class)
				     (member (cadar pairs) class)))
			       rest-classes)))
	(cons (cond ((null? eq) (car pairs))
		    ((null? (cdr eq))
		     (lset-union equal? (car pairs) (car eq)))
		    (else (apply append eq)))
	      uneq)))))

;; crossmaps

(define (generic-crossmap mapping f ls1 ls2)
  (append-map
    (lambda (elem1)
      (mapping (lambda (elem2) (f elem1 elem2)) ls2))
    ls1))

(define (crossmap f ls1 ls2) (generic-crossmap map f ls1 ls2))
(define (append-crossmap f ls1 ls2) (generic-crossmap append-map f ls1 ls2))
(define (filter-crossmap f ls1 ls2) (generic-crossmap filter-map f ls1 ls2))

;; cleaning non-maximal elements by arbitrary partial order

(define (cleanup-by-partial-order > ls)
  (cond ((null? ls) '())
	((member (car ls) (cdr ls) (lambda (x e) (> e x)))
	 (cleanup-by-partial-order > (cdr ls)))
	(else
	  (cons (car ls)
		(cleanup-by-partial-order > (delete (car ls) (cdr ls) >))))))

(define cleanup/po cleanup-by-partial-order)