Permalink
Switch branches/tags
Find file
Fetching contributors…
Cannot retrieve contributors at this time
312 lines (285 sloc) 8.62 KB
;;; copyright by Peter Thiemann 1998, 1999
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; identity
(define (id x) x) ;big-util: identity
;;; successor
(define (succ x) (+ x 1))
(define (pred x) (- x 1))
;;; unit of the continuation monad
(define (result-c v) (lambda (k) (k v)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define any->symbol ;big-util: concatenate-symbol
(lambda args
(string->symbol
(apply string-append
(map (lambda (arg)
(cond
((symbol? arg) (symbol->string arg))
((string? arg) arg)
((number? arg) (number->string arg))))
args)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define trim-symbol
(lambda (sym)
(let ((s (symbol->string sym)))
(let loop ((i (- (string-length s) 1)))
(if (< i 0)
sym
(let ((c (string-ref s i)))
(case (string-ref s i)
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\_)
(loop (- i 1)))
(else
(substring s 0 (+ i 1))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; auxiliary
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; list of n results of applying thunk
(define (nlist n thunk)
(let loop ((n n))
(if (zero? n)
'()
(cons (thunk) (loop (- n 1))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; sets rep. by sets without repeated elements; compared w/ eq?
(define (set-include s e)
(if (null? s)
(list e)
(if (memq e s)
s
(cons e s))))
(define (set-union s1 s2)
(if (null? s1) s2
(if (memq (car s1) s2)
(set-union (cdr s1) s2)
(cons (car s1) (set-union (cdr s1) s2)))))
(define (set-intersection s1 s2)
(if (null? s1)
'()
(if (memq (car s1) s2)
(cons (car s1) (set-intersection (cdr s1) s2))
(set-intersection (cdr s1) s2))))
(define (set-subtract s e)
(if (null? s)
'()
(if (eq? e (car s))
(cdr s)
(cons (car s) (set-subtract (cdr s) e)))))
(define (set-difference s1 s2)
(if (null? s1)
'()
(let ((el (car s1))
(rest (set-difference (cdr s1) s2)))
(if (memq el s2)
rest
(cons el rest)))))
(define (set-union* . sets)
(if (null? sets)
'()
(set-union (car sets) (apply set-union* (cdr sets)))))
(define (set-equal? xs ys)
(and (and-map (lambda (x) (member x ys)) xs)
(and-map (lambda (y) (member y xs)) ys)))
(define (and-map p? xs)
(or (null? xs)
(and (p? (car xs))
(and-map p? (cdr xs)))))
(define (and-map2 p? xs ys)
(or (null? xs)
(and (p? (car xs) (car ys))
(and-map2 p? (cdr xs) (cdr ys)))))
(define (strict-and-map p? xs)
(or (null? xs)
(let ((h (p? (car xs)))
(t (strict-and-map p? (cdr xs))))
(and h t))))
(define (strict-or-map p? xs)
(and (pair? xs)
(let ((h (p? (car xs)))
(t (strict-or-map p? (cdr xs))))
(or h t))))
(define (or-map p? xs)
(and (pair? xs)
(or (p? (car xs))
(or-map p? (cdr xs)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (generic-sort leq x*)
(let loop ((x* x*) (result '()))
(if (null? x*)
result
(loop (cdr x*) (generic-insert leq (car x*) result)))))
(define (generic-insert leq x x*)
(let loop ((x* x*))
(if (null? x*)
(list x)
(let ((x1 (car x*)))
(if (leq x x1)
(cons x x*)
(cons x1 (loop (cdr x*))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (filter p xs) ;big-util
(if (null? xs)
'()
(if (p (car xs))
(cons (car xs) (filter p (cdr xs)))
(filter p (cdr xs)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (remove-duplicates l) ;big-util
(let loop ((l l) (u '()))
(if (null? l)
u
(let ((e (car l)))
(if (member e u)
(loop (cdr l) u)
(loop (cdr l) (cons e u)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (countq e l)
(let loop ((l l) (r 0))
(if (pair? l)
(if (eq? (car l) e)
(loop (cdr l) (+ r 1))
(loop (cdr l) r))
r)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (list-or l)
(and (pair? l)
(or (car l) (list-or (cdr l)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (take n l)
(let loop ((n n) (l l) (acc '()))
(if (or (zero? n) (null? l))
(reverse acc)
(loop (- n 1) (cdr l) (cons (car l) acc)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (thread-map f in xs)
(if (null? xs)
in
(let ((out (f (car xs) in)))
(thread-map f out (cdr xs)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax load-program
(syntax-rules ()
((_ prg) (eval `(BEGIN ,@prg) (interaction-environment)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; I/O: read a list of Scheme objects
(define (file->list filename)
(with-input-from-file filename
(lambda ()
(let loop ((obj (read)))
(if (eof-object? obj)
'()
(cons obj (loop (read))))))))
;;; write a list of Scheme objects
(define (writelpp l filename)
(with-output-to-file filename
(lambda ()
(for-each p l))))
(define (writel l filename)
(with-output-to-file filename
(lambda ()
(for-each write l))))
(define (count-cells x)
(if (pair? x)
(+ 1 (count-cells (car x)) (count-cells (cdr x)))
1))
;;;
(define (display-line . objs)
(for-each display objs)
(newline))
(define display-return
(lambda (x) (display-line "returning " x) x))
(define display-list
(lambda (l) (for-each (lambda (x) (display x) (display " ")) l)))
(define (spaces n)
(make-string n #\space))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (strip-path-prefix path)
(let ((l (string-length path)))
(let loop ((s 0) (i 0))
(cond
((= i l)
(substring path s l))
((eq? (string-ref path i) #\/)
(loop (+ i 1) (+ i 1)))
(else
(loop s (+ i 1)))))))
(define (strip-path-suffix path)
(let ((l (string-length path)))
(let loop ((e l) (i 0))
(cond
((= i l)
(substring path 0 e))
((eq? (string-ref path i) #\.)
(loop i (+ i 1)))
((eq? (string-ref path i) #\/)
(loop l (+ i 1)))
(else
(loop e (+ i 1)))))))
(define fixnum-limit (expt 2 27)) ; leave some room for intermediate calculations
(define (assimilate-hash hash adjustment)
(modulo (+ (* 2 hash) adjustment) fixnum-limit))
(define (equal?-hash x)
(let recur ((x x)
(budget 16))
(cond
((<= budget 0) 22222222)
((string? x) (string-hash x))
((pair? x)
(assimilate-hash (recur (car x) (quotient budget 2))
(recur (cdr x) (- budget 1))))
((vector? x)
(let ((n (vector-length x)))
(cond
((zero? n) 67890123)
((= n 1)
(assimilate-hash (recur (vector-ref x 0) (- budget 1))
67890123))
((= n 2)
(assimilate-hash (recur (vector-ref x 0) (quotient budget 2))
(assimilate-hash (recur (vector-ref x 1) (quotient budget 2))
67890123)))
(else
(let ((budget (quotient budget 3)))
(assimilate-hash (recur (vector-ref x 0) budget)
(assimilate-hash (recur (vector-ref x 1) budget)
(assimilate-hash (recur (vector-ref x 2) budget)
67890123))))))))
((symbol? x)
(assimilate-hash (string-hash (symbol->string x)) ; can probably be tuned later
78901234))
((number? x)
(if (exact? x)
(cond ((integer? x)
(assimilate-hash (modulo (abs x) fixnum-limit) 56789012))
((rational? x)
(assimilate-hash (recur (numerator x) (- budget 1))
(assimilate-hash (recur (denominator x) (- budget 1))
89012345)))
((real? x) 21212121) ; would be strange
((complex? x)
(assimilate-hash (recur (real-part x) (- budget 1))
(assimilate-hash (recur (imag-part x) (- budget 1))
90123456)))
(else 21212121))
(cond ((rational? x)
(assimilate-hash (recur (inexact->exact (numerator x)) (- budget 1))
(assimilate-hash (recur (inexact->exact (denominator x)) (- budget 1))
12345601)))
((real? x) 21212121) ; NaN, infinity
((complex? x)
(assimilate-hash (recur (real-part x) (- budget 1))
(assimilate-hash (recur (imag-part x) (- budget 1))
23456012)))
(else 21212121))))
((char? x)
(assimilate-hash (char->integer x) 345670123))
((string? x)
(assimilate-hash (string-hash x) 456789012))
((eq? x #t)
(assimilate-hash 1 112223344))
((not x)
(assimilate-hash 2 112223344))
((null? x)
(assimilate-hash 3 112223344))
((procedure? x) 443322110)
(else 332211005))))