;;;; -*- mode:Scheme -*- ;;;;

(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define rest cdr)

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

(define (identity x) x)

;;; COMPATIBILITY

;;; Uncomment the appropriate line for your Scheme.
(define (scheme-eval x)
  ;; In MIT Scheme, eval requires a specified environment
  (eval x user-initial-environment)
  ;; In SCM, the environment argument is not required
  ;;(eval x)
  )

(define (map-non-false list fn)
  (if (null? list)
      '()
      (let ((answer (fn (first list))))
	(if answer
	    (cons answer (map-non-false (rest list) fn))
	    (map-non-false (rest list) fn)))))

;;;  Purpose:	Remove all list elements that satisfy predicate

(define (remove-if predicate elements)
  (cond ((null? elements) '())
	((predicate (first elements))
	 (remove-if predicate (rest elements)))
	(else
	 (cons (first elements)
	       (remove-if predicate (rest elements))))))

;;; Purpose:	Remove all list elements that DO NOT satisfy predicate
(define (remove-if-not predicate elements)
  (remove-if (lambda (x) (not (predicate x))) elements))

;;; Keep only elements of l for which pred is not false (same as above).
(define filter remove-if-not)

;;; Some auxiliary functions

;;; Finds the position (integer from 0) of item in the list.  The test
;;; is eq?.  If a third arg is provided then that function is applied
;;; to the list element before testing for equality.
;;; (position 'b '(a b c)) => 1
;;; (position 'b '((a 1) (b 2) (2 3)) first) => 1
(define (position item list . args)
  (let ((found #f)
	(key-fn
	 (if (null? args)
	     #f
	     (first args))))
    (do ((x list (rest x))
	 (i 0 (+ i 1)))
	((or (null? x) found))
      (if (equal? (if key-fn (key-fn (first x)) (first x)) item)
	  (set! found i)))
    found))

;;; Constructs a list of indices starting at 0 that goes up to n-1
;;; where n is the length of the list l.
;;; (index-list '(a b c)) => (0 1 2)
(define (index-list l)
  (define (index-list-aux l index)
    (if (null? l)
	'()
	(cons index (index-list-aux (rest l) (+ index 1)))))
  (index-list-aux l 0))

(define (make-index-list n)
  (define (make-index-list-aux i)
    (if (< i n) 
	(cons i (make-index-list-aux (+ 1 i)))
	'()))
  (make-index-list-aux 0))

(define (random-list-entry l)
  (if (null? l)
      (error 'random-index "called with empty list")
      (list-ref l (random (length l)))))

(define (append-map fn . x)
  (if (there-exists? x null?)
      '()
      (let ((val (apply fn (map car x))))
	(if (list? val)
	    (append val (apply append-map (cons fn (map cdr x))))
	    (error "append-map expects list values, it got this:" val)))))

(define *t:silent* #f)
(define (display* . l)
  ;; Print the list of arguments
  (cond (*t:silent* #f)
	(else
	 (for-each display l)
	 (newline))))

;;; Utilities

(define (y-or-n-p message)
  (display message)
  (display "(Y or N) ")
  (let ((answer (read)))
    (cond ((eq? answer 'y) #t)
	  ((eq? answer 'n) #f)
	  (else (y-or-n-p "Please enter Y or N: ")))))

;;; Simple printing utilities.

;;; Used to indent printouts.
(define *indent* 0)

(define (indent n)
  (if (= n 0)
      ""
      (string-append "  " (indent (- n 1)))))

(define indent-n indent)		; a synomym

; Some of the functions below are from:
; initdr.scm              Gordon S. Novak Jr.               27 Aug 01

(define (1+ n) (+ n 1))
(define (1- n) (- n 1))

; Versions of standard Lisp functions in Scheme

(define (copy-list l)
  (if (pair? l)
      (cons (car l) (copy-list (cdr l)))
      l))

(define (copy-tree x)
  (if (pair? x)
      (cons (copy-tree (car x))
            (copy-tree (cdr x)))
      x))

; Simple subst similar to copy-tree
(define (subst new old tree)
  (if (pair? tree)
      (cons (subst new old (car tree))
            (subst new old (cdr tree)))
      (if (eqv? old tree)
          new
          tree)))

; More efficient subst
(define (subst new old tree)
  (if (pair? tree)
      (let ((left (subst new old (car tree)))
            (right (subst new old (cdr tree))))
        (if (and (eq? left (car tree))
                 (eq? right (cdr tree)))
            tree
            (cons left right)))
      (if (eqv? old tree)
          new
          tree)))

; Simple sublis similar to copy-tree
(define (sublis alist tree)
  (if (pair? tree)
      (cons (sublis alist (car tree))
            (sublis alist (cdr tree)))
      (if (assv tree alist)
          (cdr (assv tree alist))
          tree)))

; More efficient sublis
(define (sublis alist tree)
  (if (pair? tree)
      (let ((left (sublis alist (car tree)))
            (right (sublis alist (cdr tree))))
        (if (and (eq? left (car tree))
                 (eq? right (cdr tree)))
            tree
            (cons left right)))
      (let ((new (assv tree alist)))
        (if new
            (cdr new)
            tree) ) ) )

(define (intersection x y)
  (if (pair? x)
      (if (memv (car x) y)
          (cons (car x) (intersection (cdr x) y))
          (intersection (cdr x) y))
      '()))

(define (union x y)
  (if (pair? x)
      (if (memv (car x) y)
          (union (cdr x) y)
          (cons (car x) (union (cdr x) y)))
      y))

(define (set-difference x y)
  (if (pair? x)
      (if (memv (car x) y)
          (set-difference (cdr x) y)
          (cons (car x) (set-difference (cdr x) y)))
      '()))

(define (subset pred lst)
  (if (pair? lst)
      (if (pred (car lst))
	  (cons (car lst)
		(subset pred (cdr lst)))
	  (subset pred (cdr lst)))
      '() ) )

(define (subset? x l)
  (if (pair? x)
      (and (memv (car x) l)
	   (subset? (cdr x) l))
      (null? x)) )

(define (every pred lst)
  (if (pair? lst)
      (if (pred (car lst))
	  (every pred (cdr lst))
	  #f)
      #t) )

(define (some pred lst)
  (if (pair? lst)
      (or (pred (car lst))
	  (some pred (cdr lst)))
      #f))

(define (nconc x y)
  (define (nconc2 x y)
    (if (pair? (cdr x))
        (nconc2 (cdr x) y)
        (set-cdr! x y)))
  (if (pair? x)
      (begin (nconc2 x y) x)
      y) )

(define (nreverse x)
  (let ((last '()) (tmp '()))
    (while (pair? x)
      (set! tmp (cdr x))
      (set-cdr! x last)
      (set! last x)
      (set! x tmp))
    last))


; Convert a floating-point number to a string of sign and at most 4 characters.
; Rounds the number so that 1.999 will come out as 2.00 , very small as 0.0 .
; numstring is written assuming that num is not too large or too small,
; i.e. num must be printable in 4 digits.
(define (numstring num)
  (let* ((numc (abs num)) (sign (if (< num 0) -1 1)) (exponent 0))
    (if (< numc 1.0e-6)
	"0.0"
	(begin
	  (if (< numc 1.0)
	      (begin (while (< numc 100)
			    (set! numc (* numc 10))
			    (set! exponent (1- exponent)))
		     (set! numc (* (round numc) (expt 10 exponent))) )
	      (set! numc (* numc 1.0001)))
	  (if (< sign 0)
	      (string-append "-"
			     (substring (number->string numc) 0
			       (min 4 (string-length (number->string numc)))))
	      (substring (number->string numc) 0
			 (min 4 (string-length (number->string numc))))) ) ) ))