; initdr.scm              Gordon S. Novak Jr.               27 Aug 01

; Definitions to add to Dr. Scheme: add the following to your file:
; (load "initdr.scm")

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