;;; LaHaShem HaAretz U'Mloah

;;; Stalin 0.10 - A global optimizing compiler for Scheme
;;; Copyright 1993, 1994, and 1995 University of Toronto. All rights reserved.
;;; Copyright 1996 Technion. All rights reserved.
;;; Copyright 1996 and 1997 University of Vermont. All rights reserved.
;;; Copyright 1997, 1998, 1999, 2000, and 2001 NEC Research Institute, Inc. All
;;; rights reserved.
;;; Copyright 2002 and 2003 Purdue University. All rights reserved.

;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.

;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.

;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

;;; written by:
;;;    Jeffrey Mark Siskind
;;;    NEC Research Institute, Inc.
;;;    4 Independence Way
;;;    Princeton NJ 08540-6620 USA
;;;    voice: 609/951-2705
;;;    FAX:   609/951-2483
;;;    Qobi@research.nj.nec.com
;;;    ftp://ftp.nj.nec.com/pub/qobi
;;;    http://www.neci.nj.nec.com/homepages/qobi

;;; Derived from the t4aug98 archive of QobiScheme, updated to the m7dec98,
;;; m24jan00, f10mar00, h22apr00, f5may00, m12jun00, and m25jun01 archives.

;;; removed: MODULE

;;; TTMTTD
;;;  1. learn how to use profiler
;;;  2. self-documentation
;;;  3. ability to abort out of button presses
;;;  4. What if debugger called inside WITH-INPUT-FROM-FILE or
;;;     WITH-OUTPUT-TO-FILE? I.e. should temporarily rebind CURRENT-INPUT-PORT
;;;     and CURRENT-OUTPUT-PORT inside debugger.
;;;  5. Should catch stack overflow error and out of memory error.
;;;  6. $, $$, and $$$ only work in debugger.
;;;  7. What about errors inside debugger?
;;;  8. Breakpoints, tracing, and timeouts.
;;;  9. Should save error string and only call format once on format-string
;;;     and args.
;;; 10. Can't nest interrupts more than two deep.
;;; 11. Need to make c-z c, c-z e, c-d, c-z a, and m-TAB work.
;;; 12. Need way to set DISPLAY, SCGCINFO, SCHEAP, SCLIMIT, SCMAXHEAP,
;;;     stack (and other) limits, and cd.
;;; 13. Maybe put back checks for "SCEVAL_INTERPRETED-PROC" and
;;;     "LOOP [inside EXEC]".

(include "Scheme-to-C-compatibility")	;added
;(include "xlib")			;changed

;(define pp write)			;added
(define (remq! x l) (panic "REMQ! is not (yet) implemented")) ;added

;;; System Conditionalization

;;; note: The following can't use TMP since the variable *TMP* might not be
;;;       initialized yet.

(define *cpu-type* #f)

(define (cpu-type)
 (unless *cpu-type*
  (system "uname -m >/tmp/QobiScheme.tmp")
  (set! *cpu-type* (first (read-file "/tmp/QobiScheme.tmp")))
  (system "rm -f /tmp/QobiScheme.tmp"))
 *cpu-type*)

(define *os-type* #f)

(define (os-type)
 (unless *os-type*
  (system "uname -s >/tmp/QobiScheme.tmp")
  (set! *os-type* (first (read-file "/tmp/QobiScheme.tmp")))
  (system "rm -f /tmp/QobiScheme.tmp"))
 *os-type*)

(define *os-version* #f)

(define (os-version)
 (unless *os-version*
  (system "uname -r >/tmp/QobiScheme.tmp")
  (set! *os-version* (first (read-file "/tmp/QobiScheme.tmp")))
  (system "rm -f /tmp/QobiScheme.tmp"))
 *os-version*)

(define *os-major-version* #f)

(define (os-major-version)
 (unless *os-major-version*
  (system "uname -r|cut -f 1 -d. >/tmp/QobiScheme.tmp")
  (set! *os-major-version*
	(string->number (first (read-file "/tmp/QobiScheme.tmp"))))
  (system "rm -f /tmp/QobiScheme.tmp"))
 *os-major-version*)

(define *os-minor-version* #f)

(define (os-minor-version)
 (unless *os-minor-version*
  (system "uname -r|cut -f 2 -d. >/tmp/QobiScheme.tmp")
  (set! *os-minor-version*
	(string->number (first (read-file "/tmp/QobiScheme.tmp"))))
  (system "rm -f /tmp/QobiScheme.tmp"))
 *os-minor-version*)

(define *os-sub-version* #f)

(define (os-sub-version)
 (unless *os-sub-version*
  (system "uname -r|cut -f 3 -d. >/tmp/QobiScheme.tmp")
  (set! *os-sub-version*
	(string->number (first (read-file "/tmp/QobiScheme.tmp"))))
  (system "rm -f /tmp/QobiScheme.tmp"))
 *os-sub-version*)

;;; Sugar

;;; removed: EVAL-WHEN

(define first car)			;changed
(define second cadr)			;changed
(define third caddr)			;changed
(define fourth cadddr)			;changed
(define (fifth x) (car (cddddr x)))
(define (sixth x) (cadr (cddddr x)))
(define (seventh x) (caddr (cddddr x)))
(define (eighth x) (cadddr (cddddr x)))
(define (ninth x) (car (cddddr (cddddr x))))
(define (tenth x) (cadr (cddddr (cddddr x))))
(define (eleventh x) (caddr (cddddr (cddddr x))))
(define (twelfth x) (cadddr (cddddr (cddddr x))))
(define rest cdr)			;changed

(define (last x) (if (null? (rest x)) (first x) (last (rest x))))

(define (sqr x) (* x x))

(define (xor a b) (if a (not b) b))

(define (identity x) x)

(define (nan? x) (not (= x x)))

;;; removed: WHILE

;;; changed: This is just a stub.
(define *panic?* #t)

(define *program* "")			;changed

;;; removed: PANIC

(define (fuck-up) (panic "This shouldn't happen"))

;;; removed: USAGE

(define (compose . fs)
 (if (null? fs)
     identity
     (lambda (x) ((apply compose (rest fs)) ((first fs) x)))))

(define (rounded-number->string x . digits-of-precision)
 (if (null? digits-of-precision)
     (number->string (inexact->exact (round x)))
     (let* ((digits (first digits-of-precision))
	    (factor (expt 10.0 digits))
	    (n (abs (inexact->exact (round (* x factor)))))
	    (s (number->string n))
	    (l (string-length s))
	    (rs (if (< n factor)
		    (string-append "0."
				   (make-string (- digits l) #\0)
				   s)
		    (string-append (substring s 0 (- l digits))
				   "."
				   (substring s (- l digits) l)))))
      (if (< x 0) (string-append "-" rs) rs))))

(define (number->string-of-length number length)
 (let ((string (number->string number)))
  (string-append (make-string (- length (string-length string)) #\space)
		 string)))

(define (number->padded-string-of-length number length)
 (when (negative? number) (fuck-up))
 (let ((string (number->string number)))
  (string-append (make-string (- length (string-length string)) #\0) string)))

(define (number->string-of-length-and-precision number length precision)
 (let* ((negative? (negative? number))
	(integer-part (inexact->exact (floor (abs number))))
	(fraction-part
	 (inexact->exact
	  (floor (* (expt 10 precision) (- (abs number) integer-part)))))
	(integer-part-string (number->string integer-part))
	(fraction-part-string (number->string fraction-part)))
  (if negative?
      (string-append
       (make-string
	(- length (string-length integer-part-string) 2 precision) #\space)
       "-"
       integer-part-string
       "."
       (make-string (- precision (string-length fraction-part-string)) #\0)
       fraction-part-string)
      (string-append
       (make-string
	(- length (string-length integer-part-string) 1 precision) #\space)
       integer-part-string
       "."
       (make-string (- precision (string-length fraction-part-string)) #\0)
       fraction-part-string))))

(define (time format-string thunk)
 (let* ((start (clock-sample))
	(result (thunk))
	(end (clock-sample)))
  (format #t format-string
	  (number->string-of-length-and-precision (- end start) 8 2))
  result))

#;(define c-getenv (foreign-procedure (char*) char* "getenv" "stdlib")) ;changed

#;(define (getenv string)
 ;; changed
 (if (zero? (c-getenv string)) #f (c-getenv string)))

(define (archive-date)
 (rm (tmp "archive-date"))
 (system (format #f "archive-date >~a" (tmp "archive-date")))
 (let ((archive-date (read-file (tmp "archive-date"))))
  (rm (tmp "archive-date"))
  (first archive-date)))

;;; Structures

;;; removed: DEFINE-STRUCTURE

;;; removed: DEFINE-STRUCTURE-INTERNAL

;;; Sequences

(define (list-set! l i x)
 (if (zero? i) (set-car! l x) (list-set! (cdr l) (- i 1) x)))

(define (list-insert l i x)
 (if (zero? i)
     (cons x l)
     (cons (first l) (list-insert (rest l) (- i 1) x))))

(define (list-remove l i)
 (if (zero? i) (rest l) (cons (first l) (list-remove (rest l) (- i 1)))))

(define (list-replace l i x)
 (if (zero? i)
     (cons x (rest l))
     (cons (first l) (list-replace (rest l) (- i 1) x))))

(define (but-last x) (reverse (rest (reverse x))))

;;; removed: SUBLIST

;;; removed: SUBVECTOR

;;; removed: EVAL-WHEN

(define (reduce f l i)
 (cond ((null? l) i)
       ((null? (rest l)) (first l))
       (else (let loop ((l (rest l)) (c (first l)))
	      (if (null? l) c (loop (rest l) (f c (first l))))))))

(define (reduce-n f n i)
 (let loop ((i 0) (c i)) (if (>= i n) c (loop (+ i 1) (f c i)))))

(define (reduce-vector f v i)
 (let ((n (vector-length v)))
  (cond ((zero? n) i)
	((= n 1) (vector-ref v 0))
	(else (let loop ((i 1) (c (vector-ref v 0)))
	       (if (= i n) c (loop (+ i 1) (f c (vector-ref v i)))))))))

(define (sum f n)
 (let loop ((n (- n 1)) (c 0))
  (if (negative? n) c (loop (- n 1) (+ c (f n))))))

(define (product f n)
 (let loop ((n (- n 1)) (c 1))
  (if (negative? n) c (loop (- n 1) (* c (f n))))))

(define (factorial n) (product (lambda (i) (+ i 1)) n))

(define (choose n m) (product (lambda (i) (/ (+ i n (- m) 1) (+ i 1))) m))

(define (some p l . &rest)
 (let loop ((l l) (&rest &rest))
  (and (not (null? l))
       (or (apply p (first l) (map first &rest))
	   (loop (rest l) (map rest &rest))))))

(define (some-n p n)
 (let loop ((i 0)) (and (< i n) (or (p i) (loop (+ i 1))))))

(define (some-vector p v . &rest)
 (let loop ((i 0))
  (and (< i (vector-length v))
       (or (apply p
		  (vector-ref v i)
		  (map (lambda (v) (vector-ref v i)) &rest))
	   (loop (+ i 1))))))

;;; removed: EVAL-WHEN

(define (every p l . &rest)
 (let loop ((l l) (&rest &rest))
  (or (null? l)
      (and (apply p (first l) (map first &rest))
	   (loop (rest l) (map rest &rest))))))

(define (every-n p n)
 (let loop ((i 0)) (or (>= i n) (and (p i) (loop (+ i 1))))))

(define (every-vector p v . &rest)
 (let loop ((i 0))
  (or (>= i (vector-length v))
      (and (apply p
		  (vector-ref v i)
		  (map (lambda (v) (vector-ref v i)) &rest))
	   (loop (+ i 1))))))

(define (one p l . &rest)
 (let loop ((l l) (&rest &rest))
  (and (not (null? l))
       (if (apply p (first l) (map first &rest))
	   (let loop ((l (rest l)) (&rest (map rest &rest)))
	    (or (null? l)
		(and (not (apply p (first l) (map first &rest)))
		     (loop (rest l) (map rest &rest)))))
	   (loop (rest l) (map rest &rest))))))

(define (one-n p n)
 (let loop ((i 0))
  (and (< i n)
       (if (p i)
	   (let loop ((i (+ i 1)))
	    (or (>= i n) (and (not (p i)) (loop (+ i 1)))))
	   (loop (+ i 1))))))

(define (one-vector p v . &rest)
 (let loop ((i 0))
  (and (< i (vector-length v))
       (if (apply p
		  (vector-ref v i)
		  (map (lambda (v) (vector-ref v i)) &rest))
	   (let loop ((i (+ i 1)))
	    (or (>= i (vector-length v))
		(and (not (apply p
				 (vector-ref v i)
				 (map (lambda (v) (vector-ref v i)) &rest)))
		     (loop (+ i 1)))))
	   (loop (+ i 1))))))

(define (for-each-indexed f l)
 (let loop ((i 0) (l l))
  (unless (null? l) (f (first l) i) (loop (+ i 1) (rest l)))))

(define (for-each-n f n)
 (let loop ((i 0)) (when (< i n) (f i) (loop (+ i 1)))))

(define (for-each-from-a-up-to-b f a b)
 (let loop ((i a)) (when (< i b) (f i) (loop (+ i 1)))))

(define (for-each-n-decreasing f n)
 (when (> n 0) (let ((i (- n 1))) (f i) (for-each-n-decreasing f i))))

(define (for-each-vector f v . &rest)
 (for-each-n
  (lambda (i)
   (apply f (vector-ref v i) (map (lambda (v) (vector-ref v i)) &rest)))
  (vector-length v)))

;;; removed: EVAL-WHEN

(define (map-indexed f l)
 ;; needs work: To eliminate REVERSE.
 (let loop ((i 0) (l l) (c '()))
  (if (null? l)
      (reverse c)
      (loop (+ i 1) (rest l) (cons (f (first l) i) c)))))

(define (map-n f n)
 ;; needs work: To eliminate REVERSE.
 (let loop ((i 0) (c '()))
  (if (< i n) (loop (+ i 1) (cons (f i) c)) (reverse c))))

(define (map-vector f v . &rest)
 ;; needs work: Won't work correctly when F is nondeterministic.
 (let ((u (make-vector (vector-length v))))
  (for-each-n
   (lambda (i)
    (vector-set!
     u i
     (apply f (vector-ref v i) (map (lambda (v) (vector-ref v i)) &rest))))
   (vector-length v))
  u))

(define (map-n-vector f n)
 (let ((v (make-vector n)))
  (let loop ((i 0))
   (when (< i n)
    (vector-set! v i (f i))
    (loop (+ i 1))))
  v))

(define (enumerate n)
 (let loop ((i (- n 1)) (c '()))
  (if (>= i 0) (loop (- i 1) (cons i c)) c)))

(define (enumerate-vector n)
 (let ((v (make-vector n)))
  (for-each-n (lambda (i) (vector-set! v i i)) n)
  v))

(define (memp p x l)
 (cond ((null? l) #f) ((p x (first l)) l) (else (memp p x (rest l)))))

(define (assp p x alist)
 (and (not (null? alist))
      (if (p x (car (first alist))) (first alist) (assp p x (rest alist)))))

(define (pairwise? p l)
 (or (null? l)
     (let loop ((l1 l) (l2 (rest l)))
      ;; needs work: To make tail recursive.
      (or (null? l2)
	  (and (p (first l1) (first l2)) (loop (rest l1) (rest l2)))))))

(define (adjoinq x l) (if (memq x l) l (cons x l)))

(define (adjoinv x l) (if (memv x l) l (cons x l)))

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

(define (adjoinp p x l) (if (memp p x l) l (cons x l)))

(define (removeq x l)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l l) (c '()))
  (cond ((null? l) (reverse c))
	((eq? x (first l)) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (removev x l)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l l) (c '()))
  (cond ((null? l) (reverse c))
	((eqv? x (first l)) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (removep p x l)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l l) (c '()))
  (cond ((null? l) (reverse c))
	((p x (first l)) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (remove-if p l)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l l) (c '()))
  (cond ((null? l) (reverse c))
	((p (first l)) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (remove-if-not p l)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l l) (c '()))
  (cond ((null? l) (reverse c))
	((p (first l)) (loop (rest l) (cons (first l) c)))
	(else (loop (rest l) c)))))

(define (positionq x l)
 (let loop ((l l) (i 0))
  (cond ((null? l) #f)
	((eq? x (first l)) i)
	(else (loop (rest l) (+ i 1))))))

(define (positionv x l)
 (let loop ((l l) (i 0))
  (cond ((null? l) #f)
	((eqv? x (first l)) i)
	(else (loop (rest l) (+ i 1))))))

(define (position x l)
 (let loop ((l l) (i 0))
  (cond ((null? l) #f)
	((equal? x (first l)) i)
	(else (loop (rest l) (+ i 1))))))

(define (positionp p x l)
 (let loop ((l l) (i 0))
  (cond ((null? l) #f)
	((p x (first l)) i)
	(else (loop (rest l) (+ i 1))))))

(define (position-if p l)
 (let loop ((l l) (i 0))
  (cond ((null? l) #f)
	((p (first l)) i)
	(else (loop (rest l) (+ i 1))))))

(define (position-if-not p l)
 (let loop ((l l) (i 0))
  (cond ((null? l) #f)
	((p (first l)) (loop (rest l) (+ i 1)))
	(else i))))

(define (findq x l)
 (let loop ((l l))
  (cond ((null? l) #f)
	((eq? x (first l)) (first l))
	(else (loop (rest l))))))

(define (findv x l)
 (let loop ((l l))
  (cond ((null? l) #f)
	((eqv? x (first l)) (first l))
	(else (loop (rest l))))))

(define (find x l)
 (let loop ((l l))
  (cond ((null? l) #f)
	((equal? x (first l)) (first l))
	(else (loop (rest l))))))

(define (findp p x l)
 (let loop ((l l))
  (cond ((null? l) #f)
	((p x (first l)) (first l))
	(else (loop (rest l))))))

(define (find-if p l)
 (let loop ((l l))
  (cond ((null? l) #f)
	((p (first l)) (first l))
	(else (loop (rest l))))))

(define (find-if-not p l)
 (let loop ((l l))
  (cond ((null? l) #f)
	((p (first l)) (loop (rest l)))
	(else (first l)))))

(define (countq x l)
 (let loop ((l l) (c 0))
  (cond ((null? l) c)
	((eq? x (first l)) (loop (rest l) (+ c 1)))
	(else (loop (rest l) c)))))

(define (countv x l)
 (let loop ((l l) (c 0))
  (cond ((null? l) c)
	((eqv? x (first l)) (loop (rest l) (+ c 1)))
	(else (loop (rest l) c)))))

(define (count x l)
 (let loop ((l l) (c 0))
  (cond ((null? l) c)
	((equal? x (first l)) (loop (rest l) (+ c 1)))
	(else (loop (rest l) c)))))

(define (countp p x l)
 (let loop ((l l) (c 0))
  (cond ((null? l) c)
	((p x (first l)) (loop (rest l) (+ c 1)))
	(else (loop (rest l) c)))))

(define (count-if p l)
 (let loop ((l l) (c 0))
  (cond ((null? l) c)
	((p (first l)) (loop (rest l) (+ c 1)))
	(else (loop (rest l) c)))))

(define (count-if-not p l)
 (let loop ((l l) (c 0))
  (cond ((null? l) c)
	((p (first l)) (loop (rest l) c))
	(else (loop (rest l) (+ c 1))))))

(define (subsetq? x y) (every (lambda (xe) (memq xe y)) x))

(define (subsetv? x y) (every (lambda (xe) (memv xe y)) x))

(define (subset? x y) (every (lambda (xe) (member xe y)) x))

(define (subsetp? p x y) (every (lambda (xe) (memp p xe y)) x))

(define (set-equalq? x y) (and (subsetq? x y) (subsetq? y x)))

(define (set-equalv? x y) (and (subsetv? x y) (subsetv? y x)))

(define (set-equal? x y) (and (subset? x y) (subset? y x)))

(define (set-equalp? p x y) (and (subsetp? p x y) (subsetp? p y x)))

(define (unionq x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (append (reverse c) y))
	((memq (first l) y) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (unionv x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (append (reverse c) y))
	((memv (first l) y) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (union x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (append (reverse c) y))
	((member (first l) y) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (unionp p x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (append (reverse c) y))
	((memp p (first l) y) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (intersectionq x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (reverse c))
	((memq (first l) y) (loop (rest l) (cons (first l) c)))
	(else (loop (rest l) c)))))

(define (intersectionv x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (reverse c))
	((memv (first l) y) (loop (rest l) (cons (first l) c)))
	(else (loop (rest l) c)))))

(define (intersection x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (reverse c))
	((member (first l) y) (loop (rest l) (cons (first l) c)))
	(else (loop (rest l) c)))))

(define (intersectionp p x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (reverse c))
	((memp p (first l) y) (loop (rest l) (cons (first l) c)))
	(else (loop (rest l) c)))))

(define (set-differenceq x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (reverse c))
	((memq (first l) y) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (set-differencev x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (reverse c))
	((memv (first l) y) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (set-difference x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (reverse c))
	((member (first l) y) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (set-differencep p x y)
 ;; needs work: To eliminate REVERSE.
 (let loop ((l x) (c '()))
  (cond ((null? l) (reverse c))
	((memp p (first l) y) (loop (rest l) c))
	(else (loop (rest l) (cons (first l) c))))))

(define (remove-duplicatesq x)
 ;; needs work: To eliminate REVERSE.
 (let loop ((x x) (c '()))
  (cond ((null? x) (reverse c))
	((memq (first x) c) (loop (rest x) c))
	(else (loop (rest x) (cons (first x) c))))))

(define (remove-duplicatesv x)
 ;; needs work: To eliminate REVERSE.
 (let loop ((x x) (c '()))
  (cond ((null? x) (reverse c))
	((memv (first x) c) (loop (rest x) c))
	(else (loop (rest x) (cons (first x) c))))))

(define (remove-duplicates x)
 ;; needs work: To eliminate REVERSE.
 (let loop ((x x) (c '()))
  (cond ((null? x) (reverse c))
	((member (first x) c) (loop (rest x) c))
	(else (loop (rest x) (cons (first x) c))))))

(define (remove-duplicatesp p x)
 ;; needs work: To eliminate REVERSE.
 (let loop ((x x) (c '()))
  (cond ((null? x) (reverse c))
	((memp p (first x) c) (loop (rest x) c))
	(else (loop (rest x) (cons (first x) c))))))

(define (equivalence-classesq x)
 ;; needs work: To make tail recursive.
 (if (null? x)
     '()
     (let* ((y (first x))
	    (x (equivalence-classesq (rest x)))
	    (z (find-if (lambda (w) (eq? y (first w))) x)))
      (if z (cons (cons y z) (removeq z x)) (cons (list y) x)))))

(define (equivalence-classesv x)
 ;; needs work: To make tail recursive.
 (if (null? x)
     '()
     (let* ((y (first x))
	    (x (equivalence-classesv (rest x)))
	    (z (find-if (lambda (w) (eqv? y (first w))) x)))
      (if z (cons (cons y z) (removeq z x)) (cons (list y) x)))))

(define (equivalence-classes x)
 ;; needs work: To make tail recursive.
 (if (null? x)
     '()
     (let* ((y (first x))
	    (x (equivalence-classes (rest x)))
	    (z (find-if (lambda (w) (equal? y (first w))) x)))
      (if z (cons (cons y z) (removeq z x)) (cons (list y) x)))))

(define (transitive-equivalence-classesp p x)
 ;; needs work: To make tail recursive.
 (if (null? x)
     '()
     (let* ((y (first x))
	    (x (transitive-equivalence-classesp p (rest x)))
	    (z (find-if (lambda (w) (p y (first w))) x)))
      (if z (cons (cons y z) (removeq z x)) (cons (list y) x)))))

(define (equivalence-classesp p x)
 ;; This wrapper is necessary since P may not be transitive.
 (define (equivalence-classesp p x)
  ;; needs work: To make tail recursive.
  (if (null? x)
      '()
      (let* ((y (first x))
	     (x (equivalence-classesp p (rest x)))
	     (z (find-if (lambda (w) (some (lambda (v) (p y v)) w)) x)))
       (if z (cons (cons y z) (removeq z x)) (cons (list y) x)))))
 (let loop ((c (map list x)))
  (let ((d (map (lambda (z) (reduce append z '()))
		(equivalence-classesp
		 (lambda (x y) (some (lambda (xe) (memp p xe y)) x)) c))))
   (if (= (length d) (length c)) d (loop d)))))

(define (topological-sort p l)
 (let loop ((l l) (c '()))
  (if (null? l)
      (reverse c)
      (let ((x (find-if
		(lambda (x1)
		 (not (some (lambda (x2) (and (not (eq? x2 x1)) (p x2 x1)))
			    l)))
		l)))
       (unless x (fuck-up))
       (loop (removeq x l) (cons x c))))))

(define (every-other list)
 (cond ((null? list) '())
       ((null? (rest list)) list)
       (else (cons (first list) (every-other (rest (rest list)))))))

(define (merge list1 list2 predicate key)
 (cond ((null? list1) list2)
       ((null? list2) list1)
       ((predicate (key (first list1)) (key (first list2)))
	(cons (first list1) (merge (rest list1) list2 predicate key)))
       (else (cons (first list2) (merge list1 (rest list2) predicate key)))))

(define (sort list predicate key)
 (if (or (null? list) (null? (rest list)))
     list
     (merge (sort (every-other list) predicate key)
	    (sort (every-other (rest list)) predicate key)
	    predicate
	    key)))

(define (minp p l)
 (when (null? l) (fuck-up))
 (let loop ((x (first l)) (l (rest l)))
  (if (null? l) x (loop (if (p x (first l)) x (first l)) (rest l)))))

(define (unionvt x y) (if (or (eq? x #t) (eq? y #t)) #t (unionv x y)))

(define (intersectionvt x y)
 (cond ((eq? x #t) y) ((eq? y #t) x) (else (intersectionv x y))))

(define (set-differencevt x y)
 (cond ((eq? y #t) '()) ((eq? x #t) x) (else (set-differencev x y))))

(define (subsetvt? x y)
 (cond ((eq? y #t) #t)
       ((eq? x #t) #f)
       (else (every (lambda (xe) (memq xe y)) x))))

(define (lexicographically<? <? =?)
 ;; note: There is a bug in Scheme->C which doesn't allow < and = to shadow
 ;;       the global bindings which is why these are named <? and =?.
 (lambda (x y)
  (let loop ((x x) (y y))
   (and (not (null? x))
	(or (<? (first x) (first y))
	    (and (=? (first x) (first y)) (loop (rest x) (rest y))))))))

(define (minimal-membersp <? =? l)
 ;; note: There is a bug in Scheme->C which doesn't allow < and = to shadow
 ;;       the global bindings which is why these are named <? and =?.
 (when (null? l) (fuck-up))
 (let loop ((xs (list (first l))) (l (rest l)))
  (if (null? l)
      xs
      (loop (cond ((<? (first l) (first xs)) (list (first l)))
		  ((=? (first l) (first xs)) (cons (first l) xs))
		  (else	xs))
	    (rest l)))))

;;; Sleep

;;; removed: C-USLEEP

(define usleep (foreign-lambda void "usleep" integer))

;;; Random

;;; removed: C-RAND

(define *rand-max* (foreign-value "RAND_MAX" integer))
(define rand (foreign-lambda integer "rand"))

(define (random-real) (/ (rand) (+ *rand-max* 1.0)))

(define (random-integer n) (inexact->exact (floor (* (random-real) n))))

(define (random-boolean) (>= (random-real) 0.5))

(define (random-member l) (list-ref l (random-integer (length l))))

(define (n-random-elements-without-replacement n x)
 (when (< (length x) n) (panic "Not enough elements"))
 (let loop ((x (map list x)) (l (length x)) (n n) (c '()))
  (if (zero? n)
      c
      (let ((e (list-ref x (random-integer l))))
       (loop (remq! e x) (- l 1) (- n 1) (cons (first e) c))))))

(define (deal x) (n-random-elements-without-replacement (length x) x))

(define (random-partition-of-size k x)
 (let ((y (deal (rest x))))
  (let loop ((u (let loop ((n (- k 1)) (x y))
		 (if (zero? n) x (loop (- n 1) (rest x)))))
	     (v (cons (list (first x))
		      (let loop ((n (- k 1)) (x y))
		       (if (zero? n)
			   '()
			   (cons (list (first x)) (loop (- n 1) (rest x))))))))
   (if (null? u)
       v
       (let* ((i (random-integer k))
	      (w (list-ref v i)))
	(loop (rest u) (cons (cons (first u) w) (removeq w v))))))))

;;; Gamma Function

(define (gamma n)
 ;; needs work: Doesn't work with n<1.
 (if (<= 1.0 n 2.0)
     ;; from CRC Standard Mathematical Tables 22nd edition
     ;; needs work: Should interpolate.
     (vector-ref '#(1.0 .99433 .98884 .98355 .97844
			.97350 .96874 .96415 .95973 .95546
			.95135 .94740 .94359 .93993 .93642
			.93304 .92980 .92670 .92373 .92089
			.91817 .91558 .91311 .91075 .90852
			.90640 .90440 .90250 .90072 .89904
			.89747 .89600 .89464 .89338 .89222
			.89115 .89018 .88931 .88854 .88785
			.88726 .88676 .88636 .88604 .88581
			.88566 .88560 .88563 .88575 .88595
			.88623 .88659 .88704 .88757 .88818
			.88887 .88964 .89049 .89142 .89243
			.89352 .89468 .89592 .89724 .89864
			.90012 .90167 .90330 .90500 .90678
			.90864 .91057 .91258 .91466 .91683
			.91906 .92137 .92376 .92623 .92877
			.93138 .93408 .93685 .93969 .94261
			.94561 .94869 .95184 .95507 .95838
			.96177 .96523 .96877 .97240 .97610
			.97988 .98374 .98768 .99171 .99581 1.0)
		 (inexact->exact (floor (* (- n 1.0) 100.0))))
     (* (- n 1) (gamma (- n 1.0)))))

(define (log-gamma n)
 ;; needs work: Doesn't work with n<1.
 (if (<= 1.0 n 2.0)
     ;; from CRC Standard Mathematical Tables 22nd edition
     ;; needs work: Should interpolate.
     ;; needs work: Should precompute the log of the table.
     (log (vector-ref '#(1.0 .99433 .98884 .98355 .97844
			     .97350 .96874 .96415 .95973 .95546
			     .95135 .94740 .94359 .93993 .93642
			     .93304 .92980 .92670 .92373 .92089
			     .91817 .91558 .91311 .91075 .90852
			     .90640 .90440 .90250 .90072 .89904
			     .89747 .89600 .89464 .89338 .89222
			     .89115 .89018 .88931 .88854 .88785
			     .88726 .88676 .88636 .88604 .88581
			     .88566 .88560 .88563 .88575 .88595
			     .88623 .88659 .88704 .88757 .88818
			     .88887 .88964 .89049 .89142 .89243
			     .89352 .89468 .89592 .89724 .89864
			     .90012 .90167 .90330 .90500 .90678
			     .90864 .91057 .91258 .91466 .91683
			     .91906 .92137 .92376 .92623 .92877
			     .93138 .93408 .93685 .93969 .94261
			     .94561 .94869 .95184 .95507 .95838
			     .96177 .96523 .96877 .97240 .97610
			     .97988 .98374 .98768 .99171 .99581 1.0)
		      (inexact->exact (floor (* (- n 1.0) 100.0)))))
     (+ (log (- n 1)) (log-gamma (- n 1.0)))))

;;; Numerical Integration

(define (integrate f a b n)
 ;; The constants are hardwired to be inexact for efficiency.
 (let ((delta (/ (- b a) n)))
  (let loop ((previous (f a)) (this (f (+ a delta))) (i 1) (s 0.0))
   (if (> i n)
       s
       (loop this
	     (f (+ a (* i delta)))
	     (+ i 1)
	     (+ s (* 0.5 (+ previous this) delta)))))))

;;; Schemer

(define *fail?* #t)

;;; removed: EITHER

;;; removed: TOP-LEVEL-FAIL

;;; changed
(define (fail)
 (when *fail?* (panic "Top-level fail"))
 (set! *fail?* #t))

;;; removed: SET-FAIL!

;;; removed: FOR-EFFECTS

;;; removed: ONE-VALUE

;;; removed: LOCAL-ONE-VALUE

;;; removed: ALL-VALUES

;;; removed: POSSIBLY?

;;; removed: NECESSARILY?

;;; removed: UPON-FAILURE

(define (unwind-trail) (set! *fail?* #f) (fail))

;;; removed: UNWEDGE-TRAIL

;;; removed: LOCAL-SET!

(define (local-set-car! x y)
 (let ((p (car x))) (upon-failure (set-car! x p)))
 (set-car! x y))

(define (local-set-cdr! x y)
 (let ((p (cdr x))) (upon-failure (set-cdr! x p)))
 (set-cdr! x y))

(define (local-string-set! s i x)
 (let ((p (string-ref s i))) (upon-failure (string-set! s i p)))
 (string-set! s i x))

(define (local-vector-set! v i x)
 (let ((p (vector-ref v i))) (upon-failure (vector-set! v i p)))
 (vector-set! v i x))

(define (a-boolean)
 ;; removed: comment
 (call-with-current-continuation
  (lambda (c)
   (let ((old-fail fail))
    ;; changed
    (set! fail (lambda () (set! fail old-fail) (if *fail?* (c #f) (fail)))))
   #t)))

(define (an-integer)
 (either 0 (let ((i (an-integer-above 1))) (either i (- i)))))

(define (an-integer-above i) (either i (an-integer-above (+ i 1))))

(define (an-integer-below i) (either i (an-integer-below (- i 1))))

(define (an-integer-between i j)
 (when (> i j) (fail))
 (either i (an-integer-between (+ i 1) j)))

(define (a-member-of s)
 (if (vector? s)
     (vector-ref s (an-integer-between 0 (- (vector-length s) 1)))
     (let loop ((l s))
      (when (null? l) (fail))
      (either (first l) (loop (rest l))))))

(define (a-subset-of l)
 (if (null? l)
     '()
     (let ((y (a-subset-of (rest l)))) (either (cons (first l) y) y))))

(define (a-split-of l)
 (let loop ((x '()) (y l))
  (if (null? y)
      (list x y)
      (either (list x y) (loop (append x (list (first y))) (rest y))))))

(define (a-permutation-of l)
 (if (null? l)
     l
     (let ((split (a-split-of (a-permutation-of (rest l)))))
      (append (first split) (cons (first l) (second split))))))

(define (a-partition-of x)
 (if (null? x)
     x
     (let ((y (a-partition-of (rest x))))
      (either (cons (list (first x)) y)
	      (let ((z (a-member-of y)))
	       (cons (cons (first x) z) (removeq z y)))))))

(define (a-partition-of-size k x)
 (when (< (length x) k) (fail))
 (let loop ((x x))
  (if (= (length x) k)
      (map list x)
      (let* ((y (loop (rest x)))
	     (z (a-member-of y)))
       (cons (cons (first x) z) (removeq z y))))))

(define-structure logic-variable binding name noticers)

(define *logic-variable-counter* -1)

(define (create-logic-variable)
 (set! *logic-variable-counter* (+ *logic-variable-counter* 1))
 (let ((v (make-logic-variable
	   #f
	   (string->uninterned-symbol
	    (format #f "?~s" *logic-variable-counter*))
	   '())))
  (set-logic-variable-binding! v v)
  v))

(define (attach-noticer! x noticer)
 (cond ((logic-variable? x)
	(cond
	 ((eq? (logic-variable-binding x) x)
	  (local-set-logic-variable-noticers!
	   x (cons noticer (logic-variable-noticers x)))
	  (noticer))
	 (else (attach-noticer! (logic-variable-binding x) noticer))))
       ((pair? x)
	(attach-noticer! (car x) noticer)
	(attach-noticer! (cdr x) noticer))
       ((vector? x)
	(for-each-n (lambda (i) (attach-noticer! (vector-ref x i) noticer))
		    (vector-length x)))))

(define (value-of x)
 (cond ((logic-variable? x)
	(if (eq? (logic-variable-binding x) x)
	    x
	    (value-of (logic-variable-binding x))))
       ((pair? x) (cons (value-of (car x)) (value-of (cdr x))))
       ((vector? x) (map-vector value-of x))
       (else x)))

(define (ground? x)
 (cond ((logic-variable? x)
	(and (not (eq? (logic-variable-binding x) x))
	     (ground? (logic-variable-binding x))))
       ((pair? x) (and (ground? (car x)) (ground? (cdr x))))
       ((vector? x)
	(every-n (lambda (i) (ground? (vector-ref x i))) (vector-length x)))
       (else #t)))

(define (known?-equalv x y)
 (or (eq? x y)
     (eqv? x y)
     (and (logic-variable? x)
	  (not (eq? (logic-variable-binding x) x))
	  (known?-equalv (logic-variable-binding x) y))
     (and (logic-variable? y)
	  (not (eq? (logic-variable-binding y) y))
	  (known?-equalv x (logic-variable-binding y)))
     (and (pair? x)
	  (pair? y)
	  (known?-equalv (car x) (car y))
	  (known?-equalv (cdr x) (cdr y)))
     (and (not (logic-variable? x))
	  (not (logic-variable? y))
	  (vector? x)
	  (vector? y)
	  (= (vector-length x) (vector-length y))
	  (every-n
	   (lambda (i) (known?-equalv (vector-ref x i) (vector-ref y i)))
	   (vector-length x)))))

(define (assert!-equalv x y)
 (cond
  ((logic-variable? x)
   (cond ((and (logic-variable? y) (not (eq? (logic-variable-binding y) y)))
	  (assert!-equalv x (logic-variable-binding y)))
	 ((eq? (logic-variable-binding x) x)
	  (let loop ((y y))
	   (when (eq? x y) (fail))
	   (cond
	    ((logic-variable? y)
	     (unless (eq? (logic-variable-binding y) y)
	      (loop (logic-variable-binding y))))
	    ((pair? y) (loop (car y)) (loop (cdr y)))
	    ((vector? y) (for-each-n (lambda (i) (loop (vector-ref y i)))
				     (vector-length y)))))
	  (local-set-logic-variable-binding! x y)
	  (for-each (lambda (noticer) (noticer) (attach-noticer! y noticer))
		    (logic-variable-noticers x)))
	 (else (assert!-equalv (logic-variable-binding x) y))))
  ((logic-variable? y) (assert!-equalv y x))
  ((and (pair? x) (pair? y))
   (assert!-equalv (car x) (car y))
   (assert!-equalv (cdr x) (cdr y)))
  ((and (vector? x) (vector? y) (= (vector-length x) (vector-length y)))
   (for-each-n (lambda (i) (assert!-equalv (vector-ref x i) (vector-ref y i)))
	       (vector-length x)))
  ((not (eqv? x y)) (fail))))

(define (assert!-notv-equalv x y)
 (when (known?-equalv x y) (fail))
 (attach-noticer! x (lambda () (when (known?-equalv x y) (fail))))
 (attach-noticer! y (lambda () (when (known?-equalv x y) (fail)))))

;;; Memoization

(define-structure entry arguments continuations results)

(define (memoize f)
 (let ((cache '()))
  (lambda arguments
   ;; removed: comment
   (call-with-current-continuation
    (lambda (continuation)
     (let ((entry (find-if (lambda (e) (equal? arguments (entry-arguments e)))
			   cache)))
      (cond
       (entry (set-entry-continuations!
	       entry (cons continuation (entry-continuations entry)))
	      (a-member-of (entry-results entry)))
       (else (set! entry (make-entry arguments (list continuation) '()))
	     (set! cache (cons entry cache))
	     (let ((result (apply f arguments)))
	      (set-entry-results! entry (cons result (entry-results entry)))
	      ((a-member-of (entry-continuations entry)) result))))))))))

;;; Strings

(define (prefix? prefix string)
 (and (<= (string-length prefix) (string-length string))
      (string=? prefix (substring string 0 (string-length prefix)))))

;;; removed: STRING-REVERSE

(define (suffix? suffix string)
 (prefix? (string-reverse suffix) (string-reverse string)))

(define (directory-prefix? prefix string)
 (or (string=? prefix string) (prefix? (string-append prefix "/") string)))

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

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

(define (symbol-downcase symbol)
 (string->symbol (string-downcase (symbol->string symbol))))

(define (pad-left string n)
 (string-append (make-string (- n (string-length string)) #\space) string))

(define (pad-right string n)
 (string-append string (make-string (- n (string-length string)) #\space)))

(define (substring? s1 s2)
 (let ((n (string-length s1)))
  (some-n (lambda (i)
	   (every-n (lambda (j)
		     (char=? (string-ref s1 j) (string-ref s2 (+ j i))))
		    n))
	  (+ (- (string-length s2) n) 1))))

(define (substring-ci? s1 s2)
 (let ((n (string-length s1)))
  (some-n (lambda (i)
	   (every-n (lambda (j)
		     (char-ci=? (string-ref s1 j) (string-ref s2 (+ j i))))
		    n))
	  (+ (- (string-length s2) n) 1))))

(define (slashify string)
 (let loop ((characters (string->list string)) (result '()))
  (cond
   ((null? characters) (list->string (reverse result)))
   ((char=? (first characters) #\\)
    (loop (rest characters) (cons #\\ (cons #\\ result))))
   ((char=? (first characters) #\")
    (loop (rest characters) (cons #\" (cons #\\ result))))
   ;; note: This is not really legitimate.
   ((or (char<? (first characters) #\space)
	(char>=? (first characters) (integer->char 127)))
    (loop (rest characters)
	  (cons (integer->char
		 (+ (bit-and (char->integer (first characters)) 7)
		    (char->integer #\0)))
		(cons (integer->char
		       (+ (bit-and
			   (quotient (char->integer (first characters)) 8) 7)
			  (char->integer #\0)))
		      (cons
		       (integer->char
			(+ (bit-and
			    (quotient (char->integer (first characters)) 64) 7)
			   (char->integer #\0)))
		       (cons #\\ result))))))
   (else (loop (rest characters) (cons (first characters) result))))))

(define (string-insert-character character)
 (lambda (string position)
  (list (string-append (substring string 0 position)
		       (list->string (list character))
		       (substring string position (string-length string)))
	(+ position 1))))

(define (string-beginning-of-line string position)
 (list string 0))

(define (string-backward-char string position)
 (when (zero? position) (abort))
 (list string (- position 1)))

(define (string-delete-char string position)
 (when (= position (string-length string)) (abort))
 (list (string-append
	(substring string 0 position)
	(substring string (+ position 1) (string-length string)))
       position))

(define (string-end-of-line string position)
 (list string (string-length string)))

(define (string-forward-char string position)
 (when (= position (string-length string)) (abort))
 (list string (+ position 1)))

(define (string-kill-line string position)
 (list (substring string 0 position) position))

(define (string-backward-delete-char string position)
 (when (zero? position) (abort))
 (list (string-append (substring string 0 (- position 1))
		      (substring string position (string-length string)))
       (- position 1)))

(define (char-alphanumeric? char)
 (or (char-alphabetic? char) (char-numeric? char)))

(define (beginning-of-word? string position)
 (or (zero? position)
     (and (not (= position (string-length string)))
	  (not (char-alphanumeric? (string-ref string (- position 1))))
	  (char-alphanumeric? (string-ref string position)))))

(define (end-of-word? string position)
 (or (= position (string-length string))
     (and (not (zero? position))
	  (char-alphanumeric? (string-ref string (- position 1)))
	  (not (char-alphanumeric? (string-ref string position))))))

(define (string-backward-word string position)
 (when (zero? position) (abort))
 (let loop ((position (- position 1)))
  (if (beginning-of-word? string position)
      (list string position)
      (loop (- position 1)))))

(define (string-kill-word string position)
 (when (= position (string-length string)) (abort))
 (list (string-append (substring string 0 position)
		      (substring string
				 (second (string-forward-word string position))
				 (string-length string)))
       position))

(define (string-forward-word string position)
 (when (= position (string-length string)) (abort))
 (let loop ((position (+ position 1)))
  (if (end-of-word? string position)
      (list string position)
      (loop (+ position 1)))))

(define (string-backward-kill-word string position)
 (when (zero? position) (abort))
 (let ((new-position (second (string-backward-word string position))))
  (list (string-append (substring string 0 new-position)
		       (substring string position (string-length string)))
	new-position)))

;;; Fields

(define (number-of-fields string)
 (let loop ((n 0) (chars (string->list string)))
  (if (null? chars)
      n
      (if (char-whitespace? (first chars))
	  (loop n (rest chars))
	  (loop (+ n 1)
		(let loop ((chars chars))
		 (if (or (null? chars) (char-whitespace? (first chars)))
		     chars
		     (loop (rest chars)))))))))

(define (field-ref string n)
 (let loop ((n n) (chars (string->list string)))
  (if (char-whitespace? (first chars))
      (loop n (rest chars))
      (if (zero? n)
	  (let loop ((chars chars) (field '()))
	   (if (or (null? chars) (char-whitespace? (first chars)))
	       (list->string (reverse field))
	       (loop (rest chars) (cons (first chars) field))))
	  (loop (- n 1)
		(let loop ((chars chars))
		 (if (char-whitespace? (first chars))
		     chars
		     (loop (rest chars)))))))))

(define (fields string)
 (map-n (lambda (i) (field-ref string i)) (number-of-fields string)))

;;; Context-Free Grammars

;;; removed: LAZY

(define (terminal x)
 (lambda (p) (if (not (and (pair? p) (eq? (first p) x))) (fail)) (rest p)))

(define (seq . &rest)
 (if (null? &rest) list (compose (first &rest) (apply seq (rest &rest)))))

(define (alt . &rest) (a-member-of &rest))

(define (opt a) (alt (seq) a))

(define (k* a) (opt (seq a (k* a))))

(define (recognize? s words) (possibly? (null? (s words))))

;;; Line and Whole-File I/O

(define (read-line . port)
 (if (null? port) (set! port (current-input-port)) (set! port (first port)))
 (let loop ((chars '()))
  (let ((char (read-char port)))
   (if (eof-object? char)
       (if (null? chars) char (list->string (reverse chars)))
       (if (char=? char #\newline)
	   (list->string (reverse chars))
	   (loop (cons char chars)))))))

(define (read-file pathname)
 (if (string=? pathname "-")
     (let loop ((lines '()) (line (read-line)))
      (if (eof-object? line)
	  (reverse lines)
	  (loop (cons line lines) (read-line))))
     (call-with-input-file pathname
      (lambda (port)
       (let loop ((lines '()) (line (read-line port)))
	(if (eof-object? line)
	    (reverse lines)
	    (loop (cons line lines) (read-line port))))))))

(define (write-file lines pathname)
 (if (string=? pathname "-")
     (for-each (lambda (line) (display line) (newline)) lines)
     (call-with-output-file pathname
      (lambda (port)
       (for-each (lambda (line) (display line port) (newline port)) lines)))))

(define (read-object-from-file pathname)
 (if (string=? pathname "-") (read) (call-with-input-file pathname read)))

(define (write-object-to-file object pathname)
 (cond ((string=? pathname "-") (pp object) (newline))
       (else (call-with-output-file pathname
	      (lambda (port) (pp object port) (newline port))))))

(define (read-from-string string)
 (rm (tmp "cdslib.tmp"))
 (write-file (list string) (tmp "cdslib.tmp"))
 (let ((input (call-with-input-file (tmp "cdslib.tmp") read)))
  (rm (tmp "cdslib.tmp"))
  input))

;;; Pathnames

;;; needs work: missing notions: ., .., foo~, foo.~n~, .foo, #foo#, /foo/, and
;;;             foo/

(define (has-directory? pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (let loop ((l (reverse (string->list pathname))))
  (and (not (null? l)) (or (char=? (first l) #\/) (loop (rest l))))))

(define (directory pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (unless (has-directory? pathname) (panic "No directory"))
 (let ((l (string->list pathname)))
  (substring pathname 0 (- (length l) (positionv #\/ (reverse l)) 1))))

(define (strip-directory pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (if (has-directory? pathname)
     (let ((l (string->list pathname)))
      (substring pathname
		 (- (length l) (positionv #\/ (reverse l)))
		 (length l)))
     pathname))

(define (has-extension? pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (let loop ((l (reverse (string->list pathname))))
  (and (not (null? l))
       (not (char=? (first l) #\/))
       (or (char=? (first l) #\.) (loop (rest l))))))

(define (extension pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (unless (has-extension? pathname) (panic "No extension"))
 (substring pathname
	    (+ (positionv #\. (string->list pathname)) 1)
	    (string-length pathname)))

(define (strip-extension pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (let loop ((l (reverse (string->list pathname))))
  (if (or (null? l) (char=? (first l) #\/))
      pathname
      (if (char=? (first l) #\.)
	  (list->string (reverse (rest l)))
	  (loop (rest l))))))

(define (default-extension pathname extension)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (if (has-extension? pathname)
     pathname
     (string-append pathname "." extension)))

(define (replace-extension pathname extension)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (string-append (strip-extension pathname) "." extension))

;;; Temporary files

(define *tmp* "/tmp")

(define (tmp pathname) (string-append *tmp* "/" pathname))

;;; Directory/File operations

;;; removed: FOPEN

;;; removed: FCLOSE

;;; changed
(define (can-open-file-for-input? pathname)
 (or (string=? pathname "-")
     (file-exists? pathname)))

(define *system-V?* #t)

(define (quotify string)
 (let loop ((chars (string->list string)) (c '()))
  (if (null? chars)
      (list->string (reverse c))
      (loop (rest chars)
	    (cons (first chars)
		  (if (or (char=? (first chars) #\\)
			  (char=? (first chars) #\")
			  (char=? (first chars) #\$)
			  (char=? (first chars) #\&))
		      (cons #\\ c)
		      c))))))

#;(define (file-exists? pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (system (format #f "~als -ld ~a >~a 2>~a"
		 (if *system-V?* "" "/usr/5bin/")
		 (quotify pathname)
		 (tmp "QobiScheme.ls")
		 (tmp "QobiScheme.stderr")))
 (unless (or (eof-object?
	      (call-with-input-file (tmp "QobiScheme.stderr") read-line))
	     (string=?
	      (call-with-input-file (tmp "QobiScheme.stderr") read-line)
	      (format #f "ls: ~a: No such file or directory"
		      (quotify pathname))))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.ls")))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.stderr")))
  (fuck-up))
 (let ((result (not (eof-object?
		     (call-with-input-file (tmp "QobiScheme.ls") read-line)))))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.ls")))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.stderr")))
  result))

(define (directory-list pattern)
 (system
  (format #f "ls -A ~a >~a 2>~a"
	  (quotify pattern) (tmp "QobiScheme.ls") (tmp "QobiScheme.stderr")))
 (unless (or (eof-object?
	      (call-with-input-file (tmp "QobiScheme.stderr") read-line))
	     (string=?
	      (call-with-input-file (tmp "QobiScheme.stderr") read-line)
	      (format #f "ls: ~a: No such file or directory"
		      (quotify pattern))))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.ls")))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.stderr")))
  (fuck-up))
 (let ((result (read-file (tmp "QobiScheme.ls"))))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.ls")))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.stderr")))
  result))

(define (recursive-directory-list pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (unless (file-exists? pathname)
  (panic "Can't get recursive directory list for nonexistent file"))
 (system (format #f "find ~a -print >~a 2>~a"
		 (quotify pathname)
		 (tmp "QobiScheme.find")
		 (tmp "QobiScheme.stderr")))
 (unless (eof-object?
	  (call-with-input-file (tmp "QobiScheme.stderr") read-line))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.find")))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.stderr")))
  (fuck-up))
 (let ((result (read-file (tmp "QobiScheme.find"))))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.find")))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.stderr")))
  result))

(define (file-info pathname id?)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (unless (file-exists? pathname) (panic "Can't get info for nonexistent file"))
 (system (format #f "~als -~ad ~a >~a 2>~a"
		 (if *system-V?* "" "/usr/5bin/")
		 (if id? "n" "l")
		 (quotify pathname)
		 (tmp "QobiScheme.ls")
		 (tmp "QobiScheme.stderr")))
 (unless (eof-object?
	  (call-with-input-file (tmp "QobiScheme.stderr") read-line))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.ls")))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.stderr")))
  (fuck-up))
 (let ((result (call-with-input-file (tmp "QobiScheme.ls") read-line)))
  (when (eof-object? result) (fuck-up))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.ls")))
  (system (format #f "rm -f ~a" (tmp "QobiScheme.stderr")))
  result))

(define (file-permission-flags pathname) (field-ref (file-info pathname #f) 0))

(define (directory? pathname)
 (char=? (string-ref (file-permission-flags pathname) 0) #\d))

(define (symlink? pathname)
 (char=? (string-ref (file-permission-flags pathname) 0) #\l))

(define (file? pathname)
 (char=? (string-ref (file-permission-flags pathname) 0) #\-))

(define (file-number-of-links pathname)
 (string->number (field-ref (file-info pathname #f) 1)))

(define (file-userid pathname)
 (let ((result (field-ref (file-info pathname #f) 2)))
  (when (integer? (string->number result)) (panic "Can't get userid"))
  result))

(define (file-uid pathname)
 (let ((result (string->number (field-ref (file-info pathname #f) 2))))
  (unless (integer? result) (panic "Can't get uid"))
  result))

(define (file-groupid pathname)
 (let ((result (field-ref (file-info pathname #f) 3)))
  (when (integer? (string->number result)) (panic "Can't get groupid"))
  result))

(define (file-gid pathname)
 (let ((result (string->number (field-ref (file-info pathname #f) 3))))
  (unless (integer? result) (panic "Can't get gid"))
  result))

(define (file-length pathname)
 (string->number (field-ref (file-info pathname #f) 4)))

(define (file-mtime-month pathname)
 (+
  (position
   (field-ref (file-info pathname #f) 5)
   '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
  1))

(define (file-mtime-date pathname)
 (string->number (field-ref (file-info pathname #f) 6)))

(define (file-mtime-time/year pathname) (field-ref (file-info pathname #f) 7))

(define (symlink-target pathname)
 (unless (symlink? pathname) (panic "Not a link"))
 (field-ref (file-info pathname #f) 10))

(define (symlink target pathname)
 (when (or (string=? target "-") (string=? pathname "-"))
  (panic "Invalid pathname"))
 (unless (zero? (system (format #f "ln -s ~a ~a 2>/dev/null"
				(quotify target) (quotify pathname))))
  (panic "SYMLINK failed")))

(define (mkdir pathname)
 (unless (zero? (system (format #f "mkdir ~a 2>/dev/null" (quotify pathname))))
  (panic "MKDIR failed")))

(define (rm pathname)
 (unless (zero? (system (format #f "rm -rf ~a" (quotify pathname))))
  (panic "RM failed")))

(define (mkfifo pathname)
 (unless (zero? (system (format #f "mkfifo ~a" (quotify pathname))))
  (panic "MKFIFO failed")))

(define (create-directory-and-parents-if-necessary target)
 (let ((pathname (directory target)))
  (unless (zero? (string-length pathname))
   (cond ((file-exists? pathname)
	  (unless (directory? pathname)
	   ;; changed
	   (panic (format #f "~a exists but is not a directory" pathname))))
	 (else (create-directory-and-parents-if-necessary pathname)
	       (mkdir pathname))))))

(define (same-contents? pathname1 pathname2)
 (when (or (string=? pathname1 "-") (string=? pathname2 "-"))
  (panic "Invalid pathname"))
 (let ((result (/ (system (format #f "cmp -s ~a ~a"
				  (quotify pathname1)
				  (quotify pathname2)))
		  256)))
  (when (> result 1) (panic "SAME-CONTENTS? failed"))
  (zero? result)))

(define (compressed? pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (and (char=? (string-ref pathname (- (string-length pathname) 2)) #\.)
      (char=? (string-ref pathname (- (string-length pathname) 1)) #\Z)))

(define (compressed pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (string-append pathname ".Z"))

(define (compress pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (system (format #f "compress -f ~a" pathname)))

(define (uncompress pathname)
 (when (string=? pathname "-") (panic "Invalid pathname"))
 (system (format #f "uncompress ~a" pathname)))

;;; removed: LD

;;; Tries

(define-structure trie n char->integer integer->char initial-value trie-node)

(define-structure trie-node table value)

(define (create-trie n char->integer integer->char . initial-value)
 (if (null? initial-value)
     (set! initial-value #f)
     (set! initial-value (first initial-value)))
 (make-trie n
	    char->integer
	    integer->char
	    initial-value
	    (make-trie-node (make-vector n #f) initial-value)))

(define (trie-ref trie string)
 (let ((m (string-length string)))
  (let loop ((trie-node (trie-trie-node trie)) (i 0))
   (if trie-node
       (if (= i m)
	   (trie-node-value trie-node)
	   (loop (vector-ref (trie-node-table trie-node)
			     ((trie-char->integer trie) (string-ref string i)))
		 (+ i 1)))
       (trie-initial-value trie)))))

(define (trie-set! trie string value)
 (let ((m (string-length string))
       (n (trie-n trie))
       (initial-value (trie-initial-value trie)))
  (let loop ((trie-node (trie-trie-node trie)) (i 0))
   (if (= i m)
       (set-trie-node-value! trie-node value)
       (let ((j ((trie-char->integer trie) (string-ref string i))))
	(unless (vector-ref (trie-node-table trie-node) j)
	 (vector-set! (trie-node-table trie-node)
		      j
		      (make-trie-node (make-vector n #f) initial-value)))
	(loop (vector-ref (trie-node-table trie-node) j) (+ i 1)))))))

(define (for-each-trie-entry p trie)
 (let loop ((trie-node (trie-trie-node trie)) (characters '()))
  (p (list->string (reverse characters)) (trie-node-value trie-node))
  (for-each-n
   (lambda (i)
    (let ((trie-node (vector-ref (trie-node-table trie-node) i)))
     (when trie-node
      (loop trie-node (cons ((trie-integer->char trie) i) characters)))))
   (vector-length (trie-node-table trie-node)))))

(define (trie->alist trie)
 (let ((alist '()))
  (for-each-trie-entry
   (lambda (key value) (set! alist (cons (cons key value) alist))) trie)
  alist))

(define (alist->trie alist n char->integer integer->char . initial-value)
 (let ((trie (if (null? initial-value)
		 (create-trie n char->integer integer->char)
		 (create-trie
		  n char->integer integer->char (first initial-value)))))
  (for-each (lambda (entry) (trie-set! trie (car entry) (cdr entry))) alist)
  trie))

;;; Vectors

(define-structure line-segment p q)

(define (p l) (line-segment-p l))

(define (q l) (line-segment-q l))

(define (x v) (vector-ref v 0))

(define (y v) (vector-ref v 1))

(define (z v) (vector-ref v 2))

(define (dot u v) (reduce-vector + (map-vector * u v) 0))

(define (cross-2d u v)			;return scalar z-component
 (- (* (x u) (y v)) (* (y u) (x v))))

(define (cross u v)
 (vector (- (* (y u) (z v)) (* (y v) (z u)))
	 (- (* (x v) (z u)) (* (x u) (z v)))
	 (- (* (x u) (y v)) (* (x v) (y u)))))

(define (v+ u v) (map-vector + u v))

(define (v- u v) (map-vector - u v))

(define (k*v k u) (map-vector (lambda (x) (* k x)) u))

(define (v= u v) (every-vector = u v))

(define (rotate-90 u) (vector (- (y u)) (x u)))

(define (rotate-180 u) (vector (- (x u)) (- (y u))))

(define (rotate-270 u) (vector (y u) (- (x u))))

(define (perpendicular? u v) (zero? (dot u v)))

(define (parallel? u v) (perpendicular? (rotate-90 u) v))

(define (magnitude-squared v) (dot v v))

(define (magnitude v) (sqrt (magnitude-squared v)))

(define (unit v) (k*v (/ (magnitude v)) v))

(define (distance-squared u v) (magnitude-squared (v- v u)))

(define (distance u v) (sqrt (distance-squared u v)))

(define (tangent l) (unit (v- (line-segment-q l) (line-segment-p l))))

(define (normal-2d l)
 (unit (vector (- (y (line-segment-p l)) (y (line-segment-q l)))
	       (- (x (line-segment-q l)) (x (line-segment-p l))))))

(define (line-segment-length l)
 (distance (line-segment-p l) (line-segment-q l)))

(define (collinear? l1 l2)
 (and (parallel? (v- (q l1) (p l1)) (v- (p l2) (p l1)))
      (parallel? (v- (q l1) (p l1)) (v- (q l2) (p l1)))
      (parallel? (v- (q l2) (p l2)) (v- (p l1) (p l2)))
      (parallel? (v- (q l2) (p l2)) (v- (q l1) (p l2)))))

(define (point-on-line-segment? r l)
 (and (parallel? (v- (q l) (p l)) (v- r (p l)))
      (<= (min (x (p l)) (x (q l))) (x r) (max (x (p l)) (x (q l))))
      (<= (min (y (p l)) (y (q l))) (y r) (max (y (p l)) (y (q l))))))

(define (intersection-point l1 l2)
 (let ((a (invert-matrix (vector (vector (- (y (p l1)) (y (q l1)))
					 (- (x (q l1)) (x (p l1))))
				 (vector (- (y (p l2)) (y (q l2)))
					 (- (x (q l2)) (x (p l2))))))))
  (and a (m*v a (vector (+ (* (- (y (p l1)) (y (q l1))) (x (p l1)))
			   (* (- (x (q l1)) (x (p l1))) (y (p l1))))
			(+ (* (- (y (p l2)) (y (q l2))) (x (p l2)))
			   (* (- (x (q l2)) (x (p l2))) (y (p l2)))))))))

(define (cross? l1 l2)
 (or (and (clockwise-angle?
	   (v- (p l2) (p l1)) (v- (q l1) (p l1)) (v- (q l2) (p l1)))
	  (clockwise-angle?
	   (v- (q l1) (p l2)) (v- (q l2) (p l2)) (v- (p l1) (p l2)))
	  (clockwise-angle?
	   (v- (q l2) (q l1)) (v- (p l1) (q l1)) (v- (p l2) (q l1)))
	  (clockwise-angle?
	   (v- (p l1) (q l2)) (v- (p l2) (q l2)) (v- (q l1) (q l2))))
     (and (clockwise-angle?
	   (v- (q l2) (p l1)) (v- (q l1) (p l1)) (v- (p l2) (p l1)))
	  (clockwise-angle?
	   (v- (p l1) (p l2)) (v- (q l2) (p l2)) (v- (q l1) (p l2)))
	  (clockwise-angle?
	   (v- (p l2) (q l1)) (v- (p l1) (q l1)) (v- (q l2) (q l1)))
	  (clockwise-angle?
	   (v- (q l1) (q l2)) (v- (p l2) (q l2)) (v- (p l1) (q l2))))))

(define (intersect? l1 l2)
 (or (point-on-line-segment? (p l1) l2)
     (point-on-line-segment? (q l1) l2)
     (cross? l1 l2)))

(define (read-line-segments-from-file pathname)
 (define (read-line-segments-from-file port)
  (let loop ((l '()))
   (let* ((x1 (read port))
	  (y1 (read port))
	  (x2 (read port))
	  (y2 (read port)))
    (if (eof-object? y2)
	(reverse l)
	(loop (cons (make-line-segment (vector x1 y1) (vector x2 y2)) l))))))
 (if (string=? pathname "-")
     (read-line-segments-from-file (current-input-port))
     (call-with-input-file (default-extension pathname "lines")
      read-line-segments-from-file)))

(define (write-line-segments-to-file line-segments pathname)
 (define (write-line-segments-to-file port)
  (for-each (lambda (l)
	     (write (x (line-segment-p l)) port)
	     (write-char #\space port)
	     (write (y (line-segment-p l)) port)
	     (write-char #\space port)
	     (write (x (line-segment-q l)) port)
	     (write-char #\space port)
	     (write (y (line-segment-q l)) port)
	     (newline port))
	    line-segments))
 (if (string=? pathname "-")
     (write-line-segments-to-file (current-output-port))
     (call-with-output-file (default-extension pathname "lines")
      write-line-segments-to-file)))

;;; Matrices

(define (make-matrix m n . &rest)
 (cond ((null? &rest) (map-n-vector (lambda (i) (make-vector n)) m))
       ((null? (rest &rest))
	(map-n-vector (lambda (i) (make-vector n (first &rest))) m))
       (else (panic "Too many arguments to MAKE-MATRIX"))))

(define (make-3-by-3-matrix a11 a12 a13 a21 a22 a23 a31 a32 a33)
 (vector (vector a11 a12 a13)
	 (vector a21 a22 a23)
	 (vector a31 a32 a33)))

(define (matrix-copy m)
 (map-vector (lambda (row) (map-vector identity row)) m))

(define (matrix-rows a) (vector-length a))

(define (matrix-columns a) (vector-length (vector-ref a 0)))

(define (matrix-ref a i j) (vector-ref (vector-ref a i) j))

(define (matrix-set! a i j x) (vector-set! (vector-ref a i) j x))

(define (matrix-row-ref a i) (vector-ref a i))

(define (matrix-column-ref a j) (map-vector (lambda (v) (vector-ref v j)) a))

(define (matrix-row-set! a i v) (vector-set! a i v))

(define (vector->row-matrix v) (vector v))

(define (vector->column-matrix v) (map-vector vector v))

(define (m+ a b) (map-vector v+ a b))

(define (m- a b) (map-vector v- a b))

(define (m*v a v) (map-vector (lambda (u) (dot u v)) a))

(define (transpose a)
 (map-n-vector (lambda (j) (matrix-column-ref a j)) (matrix-columns a)))

(define (outer-product f u v)
 (map-vector (lambda (ui) (map-vector (lambda (vj) (f ui vj)) v)) u))

(define (self-outer-product f v) (outer-product f v v))

(define (m* a b) (outer-product dot a (transpose b)))

(define (v*m v a) (m* (vector->row-matrix v) a))

(define (k*m k m)
 (map-vector (lambda (row) (map-vector (lambda (e) (* k e)) row)) m))

(define (determinant a)
 ;; The constants are hardwired to be inexact for efficiency.
 (unless (= (matrix-rows a) (matrix-columns a))
  (panic "Can only find determinant of a square matrix"))
 ;; removed: comment
 (call-with-current-continuation
  (lambda (return)
   (let* ((n (matrix-rows a))
	  (b (make-matrix n n))
	  (d 1.0))
    (for-each-n
     (lambda (i)
      (for-each-n (lambda (j) (matrix-set! b i j (matrix-ref a i j))) n))
     n)
    (for-each-n
     (lambda (i)
      ;; partial pivoting reduces rounding errors
      (let ((greatest (abs (matrix-ref b i i)))
	    (index i))
       (for-each-from-a-up-to-b
	(lambda (j)
	 (let ((x (abs (matrix-ref b j i))))
	  (when (> x greatest) (set! index j) (set! greatest x))))
	(+ i 1)
	n)
       (when (= greatest 0.0) (return 0.0))
       (unless (= index i)
	(let ((v (matrix-row-ref b i)))
	 (matrix-row-set! b i (matrix-row-ref b index))
	 (matrix-row-set! b index v)
	 (set! d (- d))))
       (let ((c (matrix-ref b i i)))
	(set! d (* d c))
	(for-each-from-a-up-to-b
	 (lambda (j) (matrix-set! b i j (/ (matrix-ref b i j) c)))
	 i
	 n)
	(for-each-from-a-up-to-b
	 (lambda (j)
	  (let ((e (matrix-ref b j i)))
	   (for-each-from-a-up-to-b
	    (lambda (k)
	     (matrix-set!
	      b j k (- (matrix-ref b j k) (* e (matrix-ref b i k)))))
	    (+ i 1)
	    n)))
	 (+ i 1)
	 n))))
     n)
    d))))

(define (invert-matrix a)
 ;; The constants are hardwired to be inexact for efficiency.
 (unless (= (matrix-rows a) (matrix-columns a))
  (panic "Can only invert a square matrix"))
 ;; removed: comment
 (call-with-current-continuation
  (lambda (abort)
   (let* ((n (matrix-rows a))
	  (c (make-matrix n n))
	  (b (make-matrix n n 0.0)))
    (for-each-n
     (lambda (i)
      (for-each-n (lambda (j) (matrix-set! c i j (matrix-ref a i j))) n))
     n)
    (for-each-n (lambda (i) (matrix-set! b i i 1.0)) n)
    (for-each-n
     (lambda (i)
      (when (zero? (matrix-ref c i i))
       (call-with-current-continuation
	(lambda (return)
	 (for-each-n (lambda (j)
		      (when (and (> j i) (not (zero? (matrix-ref c j i))))
		       (let ((e (vector-ref c i)))
			(vector-set! c i (vector-ref c j))
			(vector-set! c j e))
		       (let ((e (vector-ref b i)))
			(vector-set! b i (vector-ref b j))
			(vector-set! b j e))
		       (return #f)))
		     n)
	 (abort #f))))
      (let ((d (/ (matrix-ref c i i))))
       (for-each-n (lambda (j)
		    (matrix-set! c i j (* d (matrix-ref c i j)))
		    (matrix-set! b i j (* d (matrix-ref b i j))))
		   n)
       (for-each-n
	(lambda (k)
	 (let ((d (- (matrix-ref c k i))))
	  (unless (= k i)
	   (for-each-n
	    (lambda (j)
	     (matrix-set!
	      c k j (+ (matrix-ref c k j) (* d (matrix-ref c i j))))
	     (matrix-set!
	      b k j (+ (matrix-ref b k j) (* d (matrix-ref b i j)))))
	    n))))
	n)))
     n)
    b))))

(define *epsilon* 1e-6)

;;; changed: To use modified kilo/simplex.sc version.
(define (simplex a m1 m2 m3)
 (unless (and (>= m1 0)
	      (>= m2 0)
	      (>= m3 0)
	      (= (matrix-rows a) (+ m1 m2 m3 2)))
  (fuck-up))
 (let* ((m12 (+ m1 m2 1))
	(m (- (matrix-rows a) 2))
	(n (- (matrix-columns a) 1))
	(l1 (make-vector n))
	(l2 (make-vector m))
	(l3 (make-vector m2))
	(nl1 n)
	(iposv (make-vector m))
	(izrov (make-vector n))
	(ip 0)
	(kp 0)
	(bmax 0.0)
	(one? #f)
	(pass2? #t))
  (define (simp1 mm abs?)
   (set! kp (vector-ref l1 0))
   (set! bmax (matrix-ref a mm kp))
   (do ((k 1 (+ k 1))) ((>= k nl1))
    (when (positive?
	   (if abs?
	       (- (abs (matrix-ref a mm (vector-ref l1 k))) (abs bmax))
	       (- (matrix-ref a mm (vector-ref l1 k)) bmax)))
     (set! kp (vector-ref l1 k))
     (set! bmax (matrix-ref a mm (vector-ref l1 k))))))
  (define (simp2)
   (set! ip 0)
   (let ((q1 0.0)
	 (flag? #f))
    (do ((i 0 (+ i 1))) ((= i m))
     (if flag?
	 (when (< (matrix-ref a (vector-ref l2 i) kp) (- *epsilon*))
	  (let ((q (/ (- (matrix-ref a (vector-ref l2 i) 0))
		      (matrix-ref a (vector-ref l2 i) kp))))
	   (cond
	    ((< q q1) (set! ip (vector-ref l2 i)) (set! q1 q))
	    ((= q q1)
	     (let ((qp 0.0)
		   (q0 0.0))
	      (let loop ((k 1))
	       (when (<= k n)
		(set! qp
		      (/ (- (matrix-ref a ip k)) (matrix-ref a ip kp)))
		(set! q0 (/ (- (matrix-ref a (vector-ref l2 i) k))
			    (matrix-ref a (vector-ref l2 i) kp)))
		(when (= q0 qp) (loop (+ k 1)))))
	      (when (< q0 qp) (set! ip (vector-ref l2 i))))))))
	 (when (< (matrix-ref a (vector-ref l2 i) kp) (- *epsilon*))
	  (set! q1 (/ (- (matrix-ref a (vector-ref l2 i) 0))
		      (matrix-ref a (vector-ref l2 i) kp)))
	  (set! ip (vector-ref l2 i))
	  (set! flag? #t))))))
  (define (simp3 one?)
   (let ((piv (/ (matrix-ref a ip kp))))
    (do ((ii 0 (+ ii 1))) ((= ii (+ m (if one? 2 1))))
     (unless (= ii ip)
      (matrix-set! a ii kp (* piv (matrix-ref a ii kp)))
      (do ((kk 0 (+ kk 1))) ((= kk (+ n 1)))
       (unless (= kk kp)
	(matrix-set! a ii kk (- (matrix-ref a ii kk)
				(* (matrix-ref a ip kk)
				   (matrix-ref a ii kp))))))))
    (do ((kk 0 (+ kk 1))) ((= kk (+ n 1)))
     (unless (= kk kp)
      (matrix-set! a ip kk (* (- piv) (matrix-ref a ip kk)))))
    (matrix-set! a ip kp piv)))
  (do ((k 0 (+ k 1))) ((= k n))
   (vector-set! l1 k (+ k 1))
   (vector-set! izrov k k))
  (do ((i 0 (+ i 1))) ((= i m))
   (when (negative? (matrix-ref a (+ i 1) 0)) (fuck-up))
   (vector-set! l2 i (+ i 1))
   (vector-set! iposv i (+ n i)))
  (do ((i 0 (+ i 1))) ((= i m2)) (vector-set! l3 i #t))
  (when (positive? (+ m2 m3))
   (do ((k 0 (+ k 1))) ((= k (+ n 1)))
    (do ((i (+ m1 1) (+ i 1)) (sum 0.0 (+ sum (matrix-ref a i k))))
      ((> i m) (matrix-set! a (+ m 1) k (- sum)))))
   (let loop ()
    (simp1 (+ m 1) #f)
    (cond
     ((<= bmax *epsilon*)
      (cond
       ((< (matrix-ref a (+ m 1) 0) (- *epsilon*)) (set! pass2? #f))
       ((<= (matrix-ref a (+ m 1) 0) *epsilon*)
	(let loop ((ip1 m12))
	 (if (<= ip1 m)
	     (cond ((= (vector-ref iposv (- ip1 1)) (+ ip n -1))
		    (simp1 ip1 #t)
		    (cond ((positive? bmax) (set! ip ip1) (set! one? #t))
			  (else (loop (+ ip1 1)))))
		   (else (loop (+ ip1 1))))
	     (do ((i (+ m1 1) (+ i 1))) ((>= i m12))
	      (when (vector-ref l3 (- i m1 1))
	       (do ((k 0 (+ k 1))) ((= k (+ n 1)))
		(matrix-set! a i k (- (matrix-ref a i k)))))))))
       (else (simp2) (if (zero? ip) (set! pass2? #f) (set! one? #t)))))
     (else (simp2) (if (zero? ip) (set! pass2? #f) (set! one? #t))))
    (when one?
     (set! one? #f)
     (simp3 #t)
     (cond ((>= (vector-ref iposv (- ip 1)) (+ n m12 -1))
	    (let loop ((k 0))
	     (cond
	      ((and (< k nl1) (not (= kp (vector-ref l1 k))))
	       (loop (+ k 1)))
	      (else
	       (set! nl1 (- nl1 1))
	       (do ((is k (+ is 1))) ((>= is nl1))
		(vector-set! l1 is (vector-ref l1 (+ is 1))))
	       (matrix-set! a (+ m 1) kp (+ (matrix-ref a (+ m 1) kp) 1))
	       (do ((i 0 (+ i 1))) ((= i (+ m 2)))
		(matrix-set! a i kp (- (matrix-ref a i kp))))))))
	   ((and (>= (vector-ref iposv (- ip 1)) (+ n m1))
		 (vector-ref l3 (- (vector-ref iposv (- ip 1)) m1 n)))
	    (vector-set! l3 (- (vector-ref iposv (- ip 1)) m1 n) #f)
	    (matrix-set! a (+ m 1) kp (+ (matrix-ref a (+ m 1) kp) 1))
	    (do ((i 0 (+ i 1))) ((= i (+ m 2)))
	     (matrix-set! a i kp (- (matrix-ref a i kp))))))
     (let ((t (vector-ref izrov (- kp 1))))
      (vector-set! izrov (- kp 1) (vector-ref iposv (- ip 1)))
      (vector-set! iposv (- ip 1) t))
     (loop))))
  (and pass2?
       (let loop ()
	(simp1 0 #f)
	(cond
	 ((positive? bmax)
	  (simp2)
	  (cond
	   ((zero? ip) #t)
	   (else (simp3 #f)
		 (let ((t (vector-ref izrov (- kp 1))))
		  (vector-set! izrov (- kp 1) (vector-ref iposv (- ip 1)))
		  (vector-set! iposv (- ip 1) t))
		 (loop))))
	 (else (list iposv izrov)))))))

;;; The constants in the following are hardwired to be inexact for efficiency.

(define (quadratic1 a b c)
 (let ((d (- (* b b) (* 4.0 a c))))
  (when (and (negative? d) (< (- d) *epsilon*)) (set! d 0.0))
  (/ (+ (- b) (sqrt d)) (* 2.0 a))))

(define (quadratic2 a b c)
 (let ((d (- (* b b) (* 4.0 a c))))
  (when (and (negative? d) (< (- d) *epsilon*)) (set! d 0.0))
  (/ (- (- b) (sqrt d)) (* 2.0 a))))

(define (jacobi a)
 (unless (and (= (matrix-rows a) (matrix-columns a))
	      (every-n (lambda (i)
			(every-n (lambda (j)
				  (= (matrix-ref a i j) (matrix-ref a j i)))
				 (matrix-rows a)))
		       (matrix-rows a)))
  (panic "Can only compute eigenvalues/eigenvectors of a symmetric matrix"))
 (let* ((a (map-vector (lambda (row) (map-vector identity row)) a))
	(n (matrix-rows a))
	(d (make-vector n))
	(v (make-matrix n n 0.0))
	(b (make-vector n))
	(z (make-vector n 0.0)))
  (for-each-n (lambda (ip)
	       (matrix-set! v ip ip 1.0)
	       (vector-set! b ip (matrix-ref a ip ip))
	       (vector-set! d ip (matrix-ref a ip ip)))
	      n)
  (let loop ((i 0))
   ;; This was changed from 50 to 500 for center-surround.
   (when (> i 500) (panic "Too many iterations in JACOBI"))
   (let ((sm (sum (lambda (ip)
		   (sum (lambda (ir)
			 (let ((iq (+ ip ir 1)))
			  (abs (matrix-ref a ip iq))))
			(- n ip 1)))
		  (- n 1))))
    (unless (zero? sm)
     (let ((tresh (if (< i 3) (/ (* 0.2 sm) (* n n)) 0.0)))
      (for-each-n
       (lambda (ip)
	(for-each-n
	 (lambda (ir)
	  (let* ((iq (+ ip ir 1))
		 (g (* 100.0 (abs (matrix-ref a ip iq)))))
	   (cond
	    ((and (> i 3)
		  (= (+ (abs (vector-ref d ip)) g) (abs (vector-ref d ip)))
		  (= (+ (abs (vector-ref d iq)) g) (abs (vector-ref d iq))))
	     (matrix-set! a ip iq 0.0))
	    ((> (abs (matrix-ref a ip iq)) tresh)
	     (let* ((h (- (vector-ref d iq) (vector-ref d ip)))
		    (t (if (= (+ (abs h) g) (abs h))
			   (/ (matrix-ref a ip iq) h)
			   (let ((theta (/ (* 0.5 h) (matrix-ref a ip iq))))
			    (if (negative? theta)
				(- (/ (+ (abs theta)
					 (sqrt (+ (* theta theta) 1.0)))))
				(/ (+ (abs theta)
				      (sqrt (+ (* theta theta) 1.0))))))))
		    (c (/ (sqrt (+ (* t t) 1.0))))
		    (s (* t c))
		    (tau (/ s (+ c 1.0)))
		    (h (* t (matrix-ref a ip iq))))
	      (define (rotate a i j k l)
	       (let ((g (matrix-ref a i j))
		     (h (matrix-ref a k l)))
		(matrix-set! a i j (- g (* s (+ h (* g tau)))))
		(matrix-set! a k l (+ h (* s (- g (* h tau)))))))
	      (vector-set! z ip (- (vector-ref z ip) h))
	      (vector-set! z iq (+ (vector-ref z iq) h))
	      (vector-set! d ip (- (vector-ref d ip) h))
	      (vector-set! d iq (+ (vector-ref d iq) h))
	      (matrix-set! a ip iq 0.0)
	      (for-each-n (lambda (j)
			   (cond ((< j ip) (rotate a j ip j iq))
				 ((< ip j iq) (rotate a ip j j iq))
				 ((< iq j) (rotate a ip j iq j)))
			   (rotate v j ip j iq))
			  n))))))
	 (- n ip 1)))
       (- n 1)))
     (for-each-n (lambda (ip)
		  (vector-set! b ip (+ (vector-ref b ip) (vector-ref z ip)))
		  (vector-set! d ip (vector-ref b ip))
		  (vector-set! z ip 0.0))
		 n)
     (loop (+ i 1)))))
  (for-each-n
   (lambda (i)
    (let ((k i)
	  (p (vector-ref d i)))
     (for-each-n
      (lambda (l)
       (let* ((j (+ i l 1)))
	(when (>= (vector-ref d j) p) (set! k j) (set! p (vector-ref d j)))))
      (- n i 1))
     (unless (= k i)
      (vector-set! d k (vector-ref d i))
      (vector-set! d i p)
      (for-each-n (lambda (j)
		   (let ((p (matrix-ref v j i)))
		    (matrix-set! v j i (matrix-ref v j k))
		    (matrix-set! v j k p)))
		  n))))
   (- n 1))
  (list d (transpose v))))

(define (eigenvalues a) (first (jacobi a)))

(define (eigenvectors a) (second (jacobi a)))

(define (vector->diagonal-matrix v)
 (let ((m (make-matrix (vector-length v) (vector-length v) 0.0)))
  (for-each-n (lambda (i) (matrix-set! m i i (vector-ref v i)))
	      (vector-length v))
  m))

(define (identity-matrix n) (vector->diagonal-matrix (make-vector n 1.0)))

(define (clip-eigenvalues a v)
 (let* ((j (jacobi a))
	(e (second j)))
  (m* (transpose e)
      (m* (vector->diagonal-matrix (map-vector max v (first j))) e))))

;;; The following two routines are limited to 2-by-2 matricies.

(define (eigenvector-angle1 m)
 (if (and (< (abs (matrix-ref m 1 0)) *epsilon*)
	  (< (abs (matrix-ref m 0 1)) *epsilon*))
     (if (> (matrix-ref m 1 1) (matrix-ref m 0 0)) half-pi 0.0)
     (atan (matrix-ref m 1 0)
	   (- (vector-ref (eigenvalues m) 0) (matrix-ref m 1 1)))))

(define (eigenvector-angle2 m)
 (if (and (< (abs (matrix-ref m 1 0)) *epsilon*)
	  (< (abs (matrix-ref m 0 1)) *epsilon*))
     (if (<= (matrix-ref m 1 1) (matrix-ref m 0 0)) half-pi 0.0)
     (atan (matrix-ref m 1 0)
	   (- (vector-ref (eigenvalues m) 1) (matrix-ref m 1 1)))))

;;; Sparse Matrices

(define-structure sparse-matrix row column blank)

(define-structure sparse-matrix-row element i up down)

(define-structure sparse-matrix-column element j left right)

(define-structure sparse-matrix-element value i up down j left right)

(define (create-sparse-matrix blank)
 (make-sparse-matrix #f #f blank))

(define (sparse-matrix-ref sparse-matrix i j)
 ;; note: Could do different traversals.
 ;; note: Could terminate sooner relying upon ordering.
 ;; note: Could make equality predicate a parameter and have different values
 ;;       for rows and columns.
 (let loop ((sparse-matrix-row (sparse-matrix-row sparse-matrix)))
  (if sparse-matrix-row
      (if (= (sparse-matrix-row-i sparse-matrix-row) i)
	  (let loop ((sparse-matrix-element
		      (sparse-matrix-row-element sparse-matrix-row)))
	   (if sparse-matrix-element
	       (if (= (sparse-matrix-element-j sparse-matrix-element) j)
		   (sparse-matrix-element-value sparse-matrix-element)
		   (loop (sparse-matrix-element-right sparse-matrix-element)))
	       (sparse-matrix-blank sparse-matrix)))
	  (loop (sparse-matrix-row-down sparse-matrix-row)))
      (sparse-matrix-blank sparse-matrix))))

;;; Arrays
;;; Note: Limited error checking (although some errors will be revealed by
;;;       VECTOR addressing).

(define (make-array l . &rest)
 ;; (make-array '(m n ...) [v]) creates array with optional intial value
 (cond ((or (not (list? l)) (< (length l) 1))
	(panic "First argument to MAKE-ARRAY must be non-empty list"))
       ((> (length &rest) 1) (panic "Too many arguments to MAKE-ARRAY"))
       (else (let loop ((l l))
	      (if (null? (rest l))
		  (make-vector (first l) (if (null? &rest) '() (first &rest)))
		  (let ((v (make-vector (first l))))
		   (for-each-n (lambda (i) (vector-set! v i (loop (rest l))))
			       (first l))
		   v))))))

(define (array-ref a . &rest)
 ;; (array-ref a i j ...) returns a[i,j,...] from zero base
 (if (null? &rest)
     (panic "Too few arguments to ARRAY-REF")
     (let loop ((a a) (l &rest))
      (if (null? (rest l))
	  (vector-ref a (first l))
	  (loop (vector-ref a (first l)) (rest l))))))

(define (array-set! a v . &rest)
 ;; (array-set! a v i j ...) assigns a[i,j,...] = v.
 ;; Note: array indices are *at end* so they can have variable dimension
 (if (null? &rest)
     (panic "Too few arguments to ARRAY-SET!")
     (let loop ((a a) (l &rest))
      (if (null? (rest l))
	  (vector-set! a (first l) v)
	  (loop (vector-ref a (first l)) (rest l))))))

;;; 3D Geometry

(define-structure transform translation rotation)

(define pi (acos -1.0))

(define half-pi (/ pi 2.0))

(define two-pi (* 2.0 pi))

(define minus-pi (- pi))

(define two-pi/360 (/ two-pi 360.0))

(define three-sixty/two-pi (/ 360.0 two-pi))

(define (degrees->radians angle) (* two-pi/360 angle))

(define (radians->degrees angle) (* three-sixty/two-pi angle))

(define (normalize-rotation rotation)
 (cond ((> rotation pi) (normalize-rotation (- rotation two-pi)))
       ((<= rotation minus-pi) (normalize-rotation (+ rotation two-pi)))
       (else rotation)))

(define (rotation+ x y) (normalize-rotation (+ x y)))

(define (rotation- x y) (normalize-rotation (- x y)))

(define (angle-separation x y)
 (min (abs (rotation- x y)) (abs (rotation- y x))))

(define (rotation-matrix-2d theta)
 (let ((ct (cos theta))
       (st (sin theta)))
  (vector (vector ct (- st)) (vector st ct))))

(define (mean-angle angles)
 (atan (reduce + (map sin angles) 0) (reduce + (map cos angles) 0)))

(define (create-transform theta phi psi x y z)
 (let ((theta (degrees->radians theta))
       (phi (degrees->radians phi))
       (psi (degrees->radians psi)))
  (make-transform
   (vector x y z)
   (m* (m* (make-3-by-3-matrix 1.0 0.0 0.0
			       0.0 (cos theta) (sin theta)
			       0.0 (- (sin theta)) (cos theta))
	   (make-3-by-3-matrix (cos phi) 0.0 (sin phi)
			       0.0 1.0 0.0
			       (- (sin phi)) 0.0 (cos phi)))
       (make-3-by-3-matrix (cos psi) (sin psi) 0.0
			   (- (sin psi)) (cos psi) 0.0
			   0.0 0.0 1.0)))))

(define (compose-transforms t1 t2)
 (make-transform (v+ (m*v (transform-rotation t2) (transform-translation t1))
		     (transform-translation t2))
		 (m* (transform-rotation t2) (transform-rotation t1))))

(define (apply-transform t v)
 (v+ (transform-translation t) (m*v (transform-rotation t) v)))

(define (project v focal-length)
 (k*v (/ focal-length (z v)) (vector (x v) (y v))))

;;; Ellipses

(define-structure ellipse x0 y0 t0 a b)

(define (ellipse-center ellipse)
 (vector (ellipse-x0 ellipse) (ellipse-y0 ellipse)))

(define (ellipse-area ellipse)
 (* pi (ellipse-a ellipse) (ellipse-b ellipse)))

(define (ellipse-eccentricity ellipse)
 (/ (ellipse-a ellipse) (ellipse-b ellipse)))

(define (radial-distance theta phi) (normalize-rotation (- phi theta)))

(define (point-on-ellipse? p ellipse tolerance)
 (let* ((p0 (vector (ellipse-x0 ellipse) (ellipse-y0 ellipse)))
	(r (rotation-matrix-2d (- (ellipse-t0 ellipse))))
	(a (ellipse-a ellipse))
	(b (ellipse-b ellipse))
	(q (unit (m*v r (v- p p0)))))
  (<= (abs (- (distance p p0) (magnitude (vector (* a (x q)) (* b (y q))))))
      tolerance)))

(define (draw-ellipse display drawable gc ellipse)
 (let* ((previous-x #f)			;needs work: type pollution
	(previous-y #f)			;needs work: type pollution
	(x0 (ellipse-x0 ellipse))
	(y0 (ellipse-y0 ellipse))
	(t0 (ellipse-t0 ellipse))
	(a (ellipse-a ellipse))
	(b (ellipse-b ellipse))
	(rxx (cos t0))
	(rxy (- (sin t0)))
	(ryx (- rxy))
	(ryy rxx))
  (for-each-n
   (lambda (i)
    (let* ((ellipse-x (* a (sin (degrees->radians (* 10 i)))))
	   (ellipse-y (* b (cos (degrees->radians (* 10 i)))))
	   (this-x (+ (* rxx ellipse-x) (* rxy ellipse-y) x0))
	   (this-y (+ (* ryx ellipse-x) (* ryy ellipse-y) y0)))
     (when previous-x
      (xdrawline display drawable gc this-x this-y previous-x previous-y))
     (set! previous-x this-x)
     (set! previous-y this-y)))
   37)))

;;; Convex Hull

(define (same-angle? u v)
 ;; Returns #T if either U or V have zero magnitude.
 (or (and (zero? (x u)) (zero? (y u)))
     (and (zero? (x v)) (zero? (y v)))
     (and (eq? (negative? (x u)) (negative? (x v)))
	  (eq? (negative? (y u)) (negative? (y v)))
	  (parallel? u v))))

(define (clockwise-angle? u v w)
 (if (negative? (x u))
     (if (negative? (y u))
	 ;; U is in third quadrant
	 (clockwise-angle? (rotate-180 u) (rotate-180 v) (rotate-180 w))
	 ;; U is in second quadrant
	 (clockwise-angle? (rotate-270 u) (rotate-270 v) (rotate-270 w)))
     (if (negative? (y u))
	 ;; U is in fourth quadrant
	 (clockwise-angle? (rotate-90 u) (rotate-90 v) (rotate-90 w))
	 ;; U is in first quadrant
	 (if (negative? (x v))
	     (if (negative? (y v))
		 ;; V is in third quadrant
		 (if (negative? (x w))
		     (if (negative? (y w))
			 ;; W is in third quadrant
			 (clockwise-angle? v w u)
			 ;; W is in second quadrant
			 #t)
		     (if (negative? (y w))
			 ;; W is in fourth quadrant
			 #f
			 ;; W is in first quadrant
			 (clockwise-angle? w u v)))
		 ;; V is in second quadrant
		 (if (negative? (y w))
		     ;; W is in third or fourth quadrant
		     #f
		     (if (negative? (x w))
			 ;; W is in second quadrant
			 (clockwise-angle? v w u)
			 ;; W is in first quadrant
			 (clockwise-angle? w u v))))
	     (if (negative? (y v))
		 ;; V is in fourth quadrant
		 (if (negative? (x w))
		     ;; W is in second or third quadrant
		     #t
		     (if (negative? (y w))
			 ;; W is in fourth quadrant
			 (clockwise-angle? v w u)
			 ;; W is in first quadrant
			 (clockwise-angle? w u v)))
		 ;; V is in first quadrant
		 (if (negative? (x w))
		     ;; W is in second or third quadrant
		     (> (* (x v) (y u)) (* (x u) (y v)))
		     (if (negative? (y w))
			 ;; W is in fourth quadrant
			 (> (* (x v) (y u)) (* (x u) (y v)))
			 ;; W is in first quadrant
			 (or (and (> (* (x v) (y u)) (* (x u) (y v)))
				  (> (* (x w) (y v)) (* (x v) (y w))))
			     (and (> (* (x w) (y v)) (* (x v) (y w)))
				  (> (* (x u) (y w)) (* (x w) (y u))))
			     (and (> (* (x u) (y w)) (* (x w) (y u)))
				  (> (* (x v) (y u)) (* (x u) (y v))))))))))))

(define (clockwise-or-same-angle? u v w)
 (if (negative? (x u))
     (if (negative? (y u))
	 ;; U is in third quadrant
	 (clockwise-or-same-angle?
	  (rotate-180 u) (rotate-180 v) (rotate-180 w))
	 ;; U is in second quadrant
	 (clockwise-or-same-angle?
	  (rotate-270 u) (rotate-270 v) (rotate-270 w)))
     (if (negative? (y u))
	 ;; U is in fourth quadrant
	 (clockwise-or-same-angle? (rotate-90 u) (rotate-90 v) (rotate-90 w))
	 ;; U is in first quadrant
	 (if (negative? (x v))
	     (if (negative? (y v))
		 ;; V is in third quadrant
		 (if (negative? (x w))
		     (if (negative? (y w))
			 ;; W is in third quadrant
			 (clockwise-or-same-angle? v w u)
			 ;; W is in second quadrant
			 #t)
		     (if (negative? (y w))
			 ;; W is in fourth quadrant
			 #f
			 ;; W is in first quadrant
			 (clockwise-or-same-angle? w u v)))
		 ;; V is in second quadrant
		 (if (negative? (y w))
		     ;; W is in third or fourth quadrant
		     #f
		     (if (negative? (x w))
			 ;; W is in second quadrant
			 (clockwise-or-same-angle? v w u)
			 ;; W is in first quadrant
			 (clockwise-or-same-angle? w u v))))
	     (if (negative? (y v))
		 ;; V is in fourth quadrant
		 (if (negative? (x w))
		     ;; W is in second or third quadrant
		     #t
		     (if (negative? (y w))
			 ;; W is in fourth quadrant
			 (clockwise-or-same-angle? v w u)
			 ;; W is in first quadrant
			 (clockwise-or-same-angle? w u v)))
		 ;; V is in first quadrant
		 (if (negative? (x w))
		     ;; W is in second or third quadrant
		     (>= (* (x v) (y u)) (* (x u) (y v)))
		     (if (negative? (y w))
			 ;; W is in fourth quadrant
			 (>= (* (x v) (y u)) (* (x u) (y v)))
			 ;; W is in first quadrant
			 (or (and (>= (* (x v) (y u)) (* (x u) (y v)))
				  (>= (* (x w) (y v)) (* (x v) (y w))))
			     (and (>= (* (x w) (y v)) (* (x v) (y w)))
				  (>= (* (x u) (y w)) (* (x w) (y u))))
			     (and (>= (* (x u) (y w)) (* (x w) (y u)))
				  (>= (* (x v) (y u)) (* (x u) (y v))))))))))))

(define (convex-hull points)
 ;; This correctly handles collinear points, and coincident points as a special
 ;; case of collinear points. It always returns the minimal set of points that
 ;; constitute a convex hull. The return value constitutes a counterclockwise
 ;; traversal of the hull.
 (if (null? points)
     '()
     ;; START is the bottommost, rightmost point.
     (let ((start (minp (lambda (p q)
			 (or (< (y p) (y q))
			     (and (= (y p) (y q)) (> (x p) (x q)))))
			points)))
      (if (every (lambda (p) (v= p start)) points)
	  ;; If all points are coincident with START, then the hull consists
	  ;; of the single point START.
	  (list start)
	  ;; PREVIOUS is one unit to the right of START. Choose a point NEXT
	  ;; such that the ray from START to NEXT is minimally clockwise from
	  ;; the ray from START to PREVIOUS. There can be several such
	  ;; collinear points NEXT.
	  (let* ((next (minp
			(lambda (p q)
			 (or (same-angle? (v- q start) '#(1 0))
			     (and (not (same-angle? (v- p start) '#(1 0)))
				  (clockwise-or-same-angle?
				   '#(1 0) (v- p start) (v- q start)))))
			points))
		 ;; Choose the collinear point that is furthest from START.
		 (next (minp (lambda (p q)
			      (>= (distance p start) (distance q start)))
			     ;; Find all points that are collinear to NEXT
			     ;; along the ray from START to NEXT.
			     (remove-if-not
			      (lambda (p)
			       (same-angle? (v- p start) (v- next start)))
			      points))))
	   (let loop ((hull (list next start)))
	    (let* ((next
		    ;; Choose a point NEXT such that the ray from THIS to NEXT
		    ;; is minimally clockwise from the ray from THIS to
		    ;; PREVIOUS. There can be several such collinear points
		    ;; NEXT.
		    (minp (lambda (p q)
			   (or (same-angle?
				(v- q (first hull))
				(v- (second hull) (first hull)))
			       (and (not (same-angle?
					  (v- p (first hull))
					  (v- (second hull) (first hull))))
				    (clockwise-or-same-angle?
				     (v- (second hull) (first hull))
				     (v- p (first hull))
				     (v- q (first hull))))))
			  points))
		   ;; Choose the collinear point that is furthest from THIS.
		   (next (minp (lambda (p q)
				(>= (distance p (first hull))
				    (distance q (first hull))))
			       ;; Find all points that are collinear to NEXT
			       ;; along the ray from THIS to NEXT.
			       (remove-if-not
				(lambda (p)
				 (same-angle? (v- p (first hull))
					      (v- next (first hull))))
				points))))
	     (if (v= next start) hull (loop (cons next hull))))))))))

(define (concave-hull points delta)
 ;; This correctly handles collinear points, and coincident points as a special
 ;; case of collinear points. It always returns the minimal set of points that
 ;; constitute a `concave' hull. The return value constitutes a
 ;; counterclockwise traversal of the hull.
 ;; This assumes that POINTS is connected. If it is not, then the hull that is
 ;; returned may not surround all of the POINTS.
 (if (null? points)
     '()
     ;; START is the bottommost, rightmost point.
     (let ((start (minp (lambda (p q)
			 (or (< (y p) (y q))
			     (and (= (y p) (y q)) (> (x p) (x q)))))
			points)))
      (if (every (lambda (p) (or (> (distance p start) delta) (v= p start)))
		 points)
	  ;; If all points that are closer than DELTA to START are coincident
	  ;; with START, then the hull consists of the single point START.
	  (list start)
	  ;; PREVIOUS is one unit to the right of START. Choose a point NEXT
	  ;; such that the ray from START to NEXT is minimally clockwise from
	  ;; the ray from START to PREVIOUS. There can be several such
	  ;; collinear points NEXT.
	  (let* ((next
		  (minp (lambda (p q)
			 (or (same-angle? (v- q start) '#(1 0))
			     (and (not (same-angle? (v- p start) '#(1 0)))
				  (clockwise-or-same-angle?
				   '#(1 0) (v- p start) (v- q start)))))
			;; Remove the points that are further than DELTA away
			;; from THIS.
			(remove-if (lambda (p) (> (distance p start) delta))
				   points)))
		 ;; Choose the noncoincident close collinear point that is
		 ;; closest to START.
		 (next (minp (lambda (p q)
			      (<= (distance p start) (distance q start)))
			     ;; Find all points that are not coincident with
			     ;; START, closer than DELTA to START, and
			     ;; collinear to NEXT along the ray from START to
			     ;; NEXT.
			     (remove-if-not
			      (lambda (p)
			       (and (not (v= p start))
				    (<= (distance p start) delta)
				    (same-angle? (v- p start)
						 (v- next start))))
			      points))))
	   (let loop ((hull (list next start)))
	    (let* ((next
		    ;; Choose a point NEXT such that the ray from THIS to NEXT
		    ;; is minimally clockwise from the ray from THIS to
		    ;; PREVIOUS. There can be several such collinear points
		    ;; NEXT.
		    (minp (lambda (p q)
			   (or (same-angle? (v- q (first hull))
					    (v- (second hull) (first hull)))
			       (and (not (same-angle?
					  (v- p (first hull))
					  (v- (second hull) (first hull))))
				    (clockwise-or-same-angle?
				     (v- (second hull) (first hull))
				     (v- p (first hull))
				     (v- q (first hull))))))
			  ;; Remove the points that are further than DELTA away
			  ;; from THIS. Also remove those points P such that
			  ;; the line segment from THIS to P crosses some line
			  ;; segment in the current partial hull.
			  (remove-if
			   (lambda (p)
			    (or (> (distance p (first hull)) delta)
				(let ((this (first hull)))
				 (let loop ((hull (rest hull)))
				  (and
				   (not (null? (rest hull)))
				   (or (cross? (make-line-segment this p)
					       (make-line-segment
						(first hull) (second hull)))
				       (loop (rest hull))))))))
			   points)))
		   ;; Choose the noncoincident close collinear point that is
		   ;; closest to THIS.
		   (next (minp (lambda (p q)
				(<= (distance p (first hull))
				    (distance q (first hull))))
			       ;; Find all points that are not coincident with
			       ;; THIS, closer than DELTA to THIS, and
			       ;; collinear to NEXT along the ray from THIS to
			       ;; NEXT.
			       (remove-if-not
				(lambda (p)
				 (and (not (v= p (first hull)))
				      (<= (distance p (first hull)) delta)
				      (same-angle? (v- p (first hull))
						   (v- next (first hull)))))
				points))))
	     (if (v= next start)
		 (let loop ((hull hull))
		  (cond ((or (null? hull)
			     (null? (rest hull))
			     (null? (rest (rest hull))))
			 hull)
			((same-angle? (v- (second hull) (first hull))
				      (v- (third hull) (second hull)))
			 (loop (cons (first hull) (rest (rest hull)))))
			(else (cons (first hull) (loop (rest hull))))))
		 (loop (cons next hull))))))))))

(define (clockwise? p q r) (clockwise-angle? (v- q p) (v- r q) (v- p q)))

(define (crossing? points)
 (let ((line-segments (map make-line-segment
			   points
			   (append (rest points) (list (first points))))))
  (some (lambda (l1) (some (lambda (l2) (cross? l1 l2)) line-segments))
	line-segments)))

(define (triangulate points)
 ;; POINTS must be a counterclockwise traversal of the vertices of a polygon.
 ;; Returns a list of counterclockwise triangles.
 (cond
  ((null? points) '())
  ((null? (rest points))
   (list (list (first points) (first points) (first points))))
  ((v= (first points) (second points)) (triangulate (rest points)))
  ((null? (rest (rest points)))
   (list (list (second points) (first points) (first points))))
  ((same-angle? (v- (second points) (first points))
		(v- (third points) (second points)))
   (triangulate (cons (first points) (rest (rest points)))))
  ((same-angle? (v- (second points) (first points))
		(v- (second points) (third points)))
   (cons (list (third points) (second points) (first points))
	 (triangulate (cons (first points) (rest (rest points))))))
  ((and
    (clockwise? (third points) (second points) (first points))
    (not (some (lambda (p)
		(or (point-inside-triangle?
		     p (third points) (second points) (first points))
		    (and
		     (not (v= p (first points)))
		     (point-on-line-segment?
		      p
		      (make-line-segment (first points) (second points))))
		    (and
		     (not (v= p (third points)))
		     (point-on-line-segment?
		      p
		      (make-line-segment (second points) (third points))))))
	       (rest (rest (rest points))))))
   (cons (list (third points) (second points) (first points))
	 (triangulate (cons (first points) (rest (rest points))))))
  (else (triangulate (append (rest points) (list (first points)))))))

(define (perimeter-of-polygon points)
 (if (or (null? points) (null? (rest points)))
     0
     (let loop ((points (cons (last points) points)))
      (if (null? (rest points))
	  0
	  (+ (distance (first points) (second points))
	     (loop (rest points)))))))

(define (hero p q r)
 (let* ((a (distance p q))
	(b (distance q r))
	(c (distance r p))
	(s (/ (+ a b c) 2)))
  (sqrt (* s (- s a) (- s b) (- s c)))))

(define (area-of-polygon points)
 (reduce +
	 (map (lambda (triangle)
	       (hero (first triangle) (second triangle) (third triangle)))
	      (triangulate points))
	 0))

(define (point-inside-triangle? p u v w)
 (if (clockwise? u v w)
     (and (clockwise-angle? (v- v u) (v- p u) (v- w u))
	  (clockwise-angle? (v- w v) (v- p v) (v- u v))
	  (clockwise-angle? (v- u w) (v- p w) (v- v w)))
     (and (clockwise-angle? (v- w u) (v- p u) (v- v u))
	  (clockwise-angle? (v- u v) (v- p v) (v- w v))
	  (clockwise-angle? (v- v w) (v- p w) (v- u w)))))

(define (point-inside-or-on-triangle? p u v w)
 (if (clockwise? u v w)
     (and (clockwise-or-same-angle? (v- v u) (v- p u) (v- w u))
	  (clockwise-or-same-angle? (v- w v) (v- p v) (v- u v))
	  (clockwise-or-same-angle? (v- u w) (v- p w) (v- v w)))
     (and (clockwise-or-same-angle? (v- w u) (v- p u) (v- v u))
	  (clockwise-or-same-angle? (v- u v) (v- p v) (v- w v))
	  (clockwise-or-same-angle? (v- v w) (v- p w) (v- u w)))))

(define (outline-polygon points)
 (map make-line-segment points (append (rest points) (list (first points)))))

(define (fill-polygon points u v)
 ;; needs work: This is a kludge for now since POINT-INSIDE-OR-ON-TRIANGLE?
 ;;             returns #T for triangles with coincident vertices. And
 ;;             TRIANGULATE returns such triangles for concave hulls.
 (let ((triangles (remove-if (lambda (triangle)
			      (or (v= (first triangle) (second triangle))
				  (v= (second triangle) (third triangle))
				  (v= (third triangle) (first triangle))))
			     (triangulate points)))
       (points '()))
  (do ((y1 (y u) (+ y1 1))) ((>= y1 (y v)))
   (do ((x1 (x u) (+ x1 1))) ((>= x1 (x v)))
    (let ((point (vector x1 y1)))
     (when (some (lambda (triangle)
		  (point-inside-or-on-triangle?
		   point (first triangle) (second triangle) (third triangle)))
		 triangles)
      (set! points (cons point points))))))
  points))

;;; Log Space Addition

(define log-math-precision 35.0)

(define minus-infinity -inf.0)

(define infinity +inf.0)

(define nan +nan.0)

(define (add-exp e1 e2)
 (let* ((e-max (max e1 e2))
	(e-min (min e1 e2))
	(factor (floor e-min)))
  (if (= e-max minus-infinity)
      minus-infinity
      (if (> (- e-max factor) log-math-precision)
	  e-max
	  (+ (log (+ (exp (- e-max factor)) (exp (- e-min factor))))
	     factor)))))

(define (log-sum f n)
 (if (positive? n)
     (let loop ((n (- n 2)) (c (f (- n 1))))
      (if (negative? n) c (loop (- n 1) (add-exp (f n) c))))
     minus-infinity))


;;; CPU time procedures courtesy of James Rootham

(define clock (foreign-lambda int "clock")) ;changed

(define *clock-time* 0.0)
(define *clock-in-time-out* #f)
(define *start-time-out* 0.0)
(define *time-out-time* 0.0)

(define fix 0.0)
(define bad #t)

;;; changed
(define *clocks-per-second* (##sys#fudge 10))

;;; This wraparound fix only works if you sample cpu time at least every 35
;;; minutes when *CLOCKS-PER-SECOND* is 1000000. It is not as bad if
;;; *CLOCKS-PER-SECOND* is 100.
(define (read-clock)
 (let ((time (clock)))
  (if (< time 0)
      (when bad (set! fix (+ fix (expt 2.0 32))) (set! bad #f))
      (set! bad #t))
  (/ (+ time fix) *clocks-per-second*)))

(define (clock-reset)
 (read-clock)
 (set! *clock-time* 0.0)
 (set! *clock-in-time-out* #f)
 (set! *start-time-out* 0.0)
 (set! *time-out-time* 0.0))

(define (clock-sample)
 (if *clock-in-time-out*
     (- *clock-time* *time-out-time*)
     (let ((time (read-clock)))
      (set! *clock-time* time)
      (- *clock-time* *time-out-time*))))

(define (clock-time-out)
 (let ((time (read-clock)))
  (set! *start-time-out* time)
  (set! *clock-in-time-out* #t)))

(define (clock-time-in)
 (set! *clock-in-time-out* #f)
 (let ((time (read-clock)))
  (set! *time-out-time* (- (+ *time-out-time* time) *start-time-out*))))

;;; An API to C arrays courtesy of Richard Mann

;;; removed: The API to C arrays


;;; removed: DEFINE-APPLICATION

;;; Debugger

;;; removed: Debugger

;;; Command Processor

;;; removed: DEFINE-COMMAND

;;; Tam V'Nishlam Shevah L'El Borei Olam