; Mode: Scheme
;
;
; *************************************************************************
; Copyright (c) 1992 Xerox Corporation.  
; All Rights Reserved.  
;
; Use, reproduction, and preparation of derivative works are permitted.
; Any copy of this software or of any derivative work must include the
; above copyright notice of Xerox Corporation, this paragraph and the
; one after it.  Any distribution of this software or derivative works
; must comply with all applicable United States export control laws.
;
; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGES.
; *************************************************************************
;
;
; Scheme is such a wonderful language, you can't program in it!
;
; This is a library of stuff I find useful.  I'll bet there's dozens
; of these out there.
;

;
; In order to make this code more easily portable, we have to be
; explicit about its implementation dependencies.  To do this, we
; have the following variable.  Please adjust it before trying to
; run this code.  See also the macro, scheme-implementation-case,
; which follows shortly.
;
; Note that some of these dependencies (i.e. gsort) are purely for
; convenience (i.e. saving me from writing sort from scratch).
; Others are more pressing, like define-macro.
;
;
(define what-scheme-implementation
   'chicken
 ; 'mit
 ;'chez
 ;'scm
 ;'scheme48         ; Scheme 48 requires that you do:
 )                  ;    ,open big-scheme
                    ; before loading this file, in order
                    ;for sort-list to be defined.

(case what-scheme-implementation
  ((scm)
   (require 'sort)))

(define gsort
  (case what-scheme-implementation
    ((mit chicken)      (lambda (predicate list) (sort list predicate)))
    #;((chez)             (lambda (predicate list) (sort predicate list)))
    #;((scheme48)         (lambda (predicate list) (sort-list predicate list)))
    #;((scm)              (lambda (predicate list) (sort list predicate)))))



;;;(define simple-printer (lambda () barf))




(define ??? 'unspecified-result)

#;(define list*
  (lambda args
    (letrec ((chase
	      (lambda (args)
		(cond ((null? args) '())
		      ((null? (cdr args)) (car args))
		      (else (cons (car args) (chase (cdr args))))))))
      (chase args))))

#;(define apply*
    (lambda (proc . args)
      (apply proc (apply list* args))))


(define position-of
    (lambda (x lst)
      (if (eq? x (car lst)) 0 (+ 1 (position-of x (cdr lst))))))

(define map-append
    (lambda (proc . lists)
      (apply append (apply map (cons proc lists)))))

#;(define last
    (lambda (l)
      (if (null? l)
	  #f
	  (if (null? (cdr l))
	      (car l)
	      (last (cdr l))))))

#;(define every
    (lambda (test . lists)
      (let scan ((tails lists))
	(if (member #t (map null? tails))             ;(any null? lists)
	    #t
	    (and (apply test (map car tails))
		 (scan (map cdr tails)))))))

#;(define remove
    (lambda (x list)
      (cond ((null? list) '())
	    ((eq? (car list) x) (cdr list))
	    (else (cons (car list) (remove x (cdr list)))))))

(define getl
    (lambda (initargs name . not-found)
      (letrec ((scan (lambda (tail)
		       (cond ((null? tail)
			      (if (pair? not-found)
				  (car not-found)
				  (error "GETL couldn't find" name)))
			     ((eq? (car tail) name) (cadr tail))
			     (else (scan (cddr tail)))))))
	(scan initargs))))

(define union
    (lambda lists
      (apply lset-union eq? lists)))

(define collect-if
    (lambda (test? list)
      (cond ((null? list) '())
	    ((test? (car list)) (cons (car list) (collect-if test? (cdr list))))
	    (else (collect-if test? (cdr list))))))

;(define remove-unless
;    (lambda (test list)
;      (if (null? list)
;	  ()
;	  (let ((rest (remove-unless test (cdr list))))
;	    (if (test (car list))
;		(cons (car list) rest)
;		rest)))))

(define remove-duplicates
    (lambda (list)
      (delete-duplicates list eq?)))


;
; A simple topological sort.
;
; It's in this file so that both TinyClos and Objects can use it.
;
; This is a fairly modified version of code I originally got from Anurag
; Mendhekar <anurag@moose.cs.indiana.edu>.
;
;

(define compute-std-cpl
    (lambda (c get-direct-supers)
      (top-sort ((build-transitive-closure get-direct-supers) c)
		((build-constraints get-direct-supers) c)
		(std-tie-breaker get-direct-supers))))


(define top-sort
    (lambda (elements constraints tie-breaker)
      (let loop ((elements    elements)
		 (constraints constraints)
		 (result      '()))
	(if (null? elements)
	    result
	    (let ((can-go-in-now
		    (collect-if
		      (lambda (x)
			(every (lambda (constraint)
				 (or (not (eq? (cadr constraint) x))
				     (memq (car constraint) result)))
			       constraints))
		      elements)))
	      (if (null? can-go-in-now)
		  (error 'top-sort "Invalid constraints")
		  (let ((choice (if (null? (cdr can-go-in-now))
				    (car can-go-in-now)
				    (tie-breaker result
						 can-go-in-now))))
		    (loop
		      (collect-if (lambda (x) (not (eq? x choice)))
			          elements)
		      constraints
		      (append result (list choice))))))))))

(define std-tie-breaker
    (lambda (get-supers)
      (lambda (partial-cpl min-elts)
	(let loop ((pcpl (reverse partial-cpl)))
	     (let ((current-elt (car pcpl)))
	       (let ((ds-of-ce (get-supers current-elt)))
		 (let ((common (collect-if (lambda (x)
					     (memq x ds-of-ce))
					   min-elts)))
		   (if (null? common)
		       (if (null? (cdr pcpl))
			   (error 'std-tie-breaker "Nothing valid")
			   (loop (cdr pcpl)))
		       (car common)))))))))


(define build-transitive-closure
    (lambda (get-follow-ons)
      (lambda (x)
	(let track ((result '())
		    (pending (list x)))
	     (if (null? pending)
		 result
		 (let ((next (car pending)))
		   (if (memq next result)
		       (track result (cdr pending))
		       (track (cons next result)
			      (append (get-follow-ons next)
				      (cdr pending))))))))))

(define build-constraints
  (lambda (get-follow-ons)
    (lambda (x)
      (let loop ((elements ((build-transitive-closure get-follow-ons) x))
		 (this-one '())
		 (result '()))
	   (if (or (null? this-one) (null? (cdr this-one)))
	       (if (null? elements)
		   result
		   (loop (cdr elements)
			 (cons (car elements)
			       (get-follow-ons (car elements)))
			 result))
	       (loop elements
		     (cdr this-one)
		     (cons (list (car this-one) (cadr this-one))
			   result)))))))

; TS 05 November, 2009
(define filter-in filter)