258 lines
7.2 KiB
Scheme
258 lines
7.2 KiB
Scheme
; 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, schemeimplementationcase,


; 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 definemacro.


;


;


(define whatschemeimplementation


'mit


;'chez


;'scm


;'scheme48 ; Scheme 48 requires that you do:


) ; ,open bigscheme


; before loading this file, in order


;for sortlist to be defined.




(case whatschemeimplementation


((scm)


(require 'sort)))




(define gsort


(case whatschemeimplementation


((mit) (lambda (predicate list) (sort list predicate)))


((chez) (lambda (predicate list) (sort predicate list)))


((scheme48) (lambda (predicate list) (sortlist predicate list)))


((scm) (lambda (predicate list) (sort list predicate)))))








(define simpleprinter (lambda () barf))










(define ??? 'unspecifiedresult)




(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 positionof


(lambda (x lst)


(if (eq? x (car lst)) 0 (+ 1 (positionof x (cdr lst))))))




(define mapappend


(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 . notfound)


(letrec ((scan (lambda (tail)


(cond ((null? tail)


(if (pair? notfound)


(car notfound)


(error "GETL couldn't find" name)))


((eq? (car tail) name) (cadr tail))


(else (scan (cddr tail)))))))


(scan initargs))))




(define union


(lambda lists


(letrec ((clean (lambda (list result)


(cond ((null? list) result)


((memq (car list) result)


(clean (cdr list) result))


(else


(clean (cdr list) (cons (car list) result)))))))


(clean (apply append lists) '()))))




(define collectif


(lambda (test? list)


(cond ((null? list) '())


((test? (car list)) (cons (car list) (collectif test? (cdr list))))


(else (collectif test? (cdr list))))))




;(define removeunless


; (lambda (test list)


; (if (null? list)


; ()


; (let ((rest (removeunless test (cdr list))))


; (if (test (car list))


; (cons (car list) rest)


; rest)))))




(define removeduplicates


(lambda (list)


(let loop ((resultsofar '())


(remaining list))


(if (null? remaining)


resultsofar


(if (null? (memq (car remaining) resultsofar))


(loop (cons (car remaining) resultsofar)


(cdr remaining))


(loop resultsofar


(cdr remaining)))))))










;


; 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 computestdcpl


(lambda (c getdirectsupers)


(topsort ((buildtransitiveclosure getdirectsupers) c)


((buildconstraints getdirectsupers) c)


(stdtiebreaker getdirectsupers))))






(define topsort


(lambda (elements constraints tiebreaker)


(let loop ((elements elements)


(constraints constraints)


(result '()))


(if (null? elements)


result


(let ((cangoinnow


(collectif


(lambda (x)


(every (lambda (constraint)


(or (not (eq? (cadr constraint) x))


(memq (car constraint) result)))


constraints))


elements)))


(if (null? cangoinnow)


(error 'topsort "Invalid constraints")


(let ((choice (if (null? (cdr cangoinnow))


(car cangoinnow)


(tiebreaker result


cangoinnow))))


(loop


(collectif (lambda (x) (not (eq? x choice)))


elements)


constraints


(append result (list choice))))))))))




(define stdtiebreaker


(lambda (getsupers)


(lambda (partialcpl minelts)


(let loop ((pcpl (reverse partialcpl)))


(let ((currentelt (car pcpl)))


(let ((dsofce (getsupers currentelt)))


(let ((common (collectif (lambda (x)


(memq x dsofce))


minelts)))


(if (null? common)


(if (null? (cdr pcpl))


(error 'stdtiebreaker "Nothing valid")


(loop (cdr pcpl)))


(car common)))))))))






(define buildtransitiveclosure


(lambda (getfollowons)


(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 (getfollowons next)


(cdr pending))))))))))




(define buildconstraints


(lambda (getfollowons)


(lambda (x)


(let loop ((elements ((buildtransitiveclosure getfollowons) x))


(thisone '())


(result '()))


(if (or (null? thisone) (null? (cdr thisone)))


(if (null? elements)


result


(loop (cdr elements)


(cons (car elements)


(getfollowons (car elements)))


result))


(loop elements


(cdr thisone)


(cons (list (car thisone) (cadr thisone))


result)))))))
