; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; This is file base.scm.

;;;; Fundamental definitions

; Order of appearance is approximately that of the Revised^4 Report.

; Booleans

(define (not x) (if x #f #t))
(define (boolean? x) (or (eq? x #t) (eq? x #f)))

; Equality

(define (eqv? x y)
  (or (eq? x y)
      (and (number? x)
           (number? y)
           (eq? (exact? x) (exact? y))
           (= x y))))

(define (equal? obj1 obj2)
  (cond ((eqv? obj1 obj2) #t)
        ((pair? obj1)
         (and (pair? obj2)
              (equal? (car obj1) (car obj2))
              (equal? (cdr obj1) (cdr obj2))))
        ((string? obj1)
         (and (string? obj2)
              (string=? obj1 obj2)))
        ((vector? obj1)
         (and (vector? obj2)
              (let ((z (vector-length obj1)))
                (and (= z (vector-length obj2))
                     (let loop ((i 0))
                       (cond ((= i z) #t)
                             ((equal? (vector-ref obj1 i) (vector-ref obj2 i))
                              (loop (+ i 1)))
                             (else #f)))))))
        (else #f)))

; Simple number stuff

(define (> x y) (< y x))
(define (<= x y) (not (< y x)))
(define (>= x y) (not (< x y)))

(define (max first . rest)
  (reduce (lambda (x y) (if (< x y) y x))
	  first
	  rest))
(define (min first . rest)
  (reduce (lambda (x y) (if (< x y) x y))
	  first
	  rest))

(define (abs n) (if (< n 0) (- 0 n) n))

(define (zero? x) (= x 0))
(define (positive? x) (< 0 x))
(define (negative? x) (< x 0))

(define (even? n) (= 0 (remainder n 2)))
(define (odd? n) (not (even? n)))

; Lists

(define (caar   x) (car (car x)))
(define (cadr   x) (car (cdr x)))
(define (cdar   x) (cdr (car x)))
(define (cddr   x) (cdr (cdr x)))

(define (caaar  x) (caar (car x)))
(define (caadr  x) (caar (cdr x)))
(define (cadar  x) (cadr (car x)))
(define (caddr  x) (cadr (cdr x)))
(define (cdaar  x) (cdar (car x)))
(define (cdadr  x) (cdar (cdr x)))
(define (cddar  x) (cddr (car x)))
(define (cdddr  x) (cddr (cdr x)))

(define (caaaar x) (caaar (car x)))
(define (caaadr x) (caaar (cdr x)))
(define (caadar x) (caadr (car x)))
(define (caaddr x) (caadr (cdr x)))
(define (cadaar x) (cadar (car x)))
(define (cadadr x) (cadar (cdr x)))
(define (caddar x) (caddr (car x)))
(define (cadddr x) (caddr (cdr x)))
(define (cdaaar x) (cdaar (car x)))
(define (cdaadr x) (cdaar (cdr x)))
(define (cdadar x) (cdadr (car x)))
(define (cdaddr x) (cdadr (cdr x)))
(define (cddaar x) (cddar (car x)))
(define (cddadr x) (cddar (cdr x)))
(define (cdddar x) (cdddr (car x)))
(define (cddddr x) (cdddr (cdr x)))

(define (null? x) (eq? x '()))

(define (list . l) l)

(define (length l)
  (reduce (lambda (ignore n) (+ n 1)) 0 l))

(define (append . lists)
  (if (null? lists)
      '()
      (let recur ((lists lists))
	(if (null? (cdr lists))
	    (car lists)
	    (reduce cons (recur (cdr lists)) (car lists))))))

(define (reverse list)
  (append-reverse list '()))

(define (append-reverse list seed)
  (if (null? list)
      seed
      (append-reverse (cdr list) (cons (car list) seed))))

(define (list-tail l i)
  (cond ((= i 0) l)
	(else (list-tail (cdr l) (- i 1)))))

(define (list-ref l k)
  (car (list-tail l k)))

(define (mem pred)
  (lambda (obj l)
    (let loop ((l l))
      (cond ((null? l) #f)
	    ((pred obj (car l)) l)
	    (else (loop (cdr l)))))))

(define memq   (mem eq?))
(define memv   (mem eqv?))
(define member (mem equal?))

(define (ass pred)
  (lambda (obj l)
    (let loop ((l l))
      (cond ((null? l) #f)
            ((pred obj (caar l)) (car l))
            (else (loop (cdr l)))))))

;(define assq  (ass eq?))
(define assv  (ass eqv?))
(define assoc (ass equal?))

; Bummed version.  Pretend that you didn't see this.

(define (assq x l)
  (cond ((null? l) #f)
	((eq? x (caar l)) (car l))
	(else (assq x (cdr l)))))

(define (list? l)			;New in R4RS
  (let recur ((l l) (lag l))		;Cycle detection
    (or (null? l)
	(and (pair? l)
	     (or (null? (cdr l))
		 (and (pair? (cdr l))
		      (not (eq? (cdr l) lag))
		      (recur (cddr l) (cdr lag))))))))

; Characters

(define (char>? x y) (char<? y x))
(define (char>=? x y) (not (char<? x y)))
(define (char<=? x y) (not (char>? x y)))

(define (char-whitespace? c)
  (if (memq (char->ascii c) ascii-whitespaces) #t #f))

(define (char-lower-case? c)
  (and (char>=? c #\a)
       (char<=? c #\z)))

(define (char-upper-case? c)
  (and (char>=? c #\A)
       (char<=? c #\Z)))

(define (char-numeric? c)
  (and (char>=? c #\0)
       (char<=? c #\9)))

(define (char-alphabetic? c)
  (or (char-upper-case? c)
      (char-lower-case? c)))

(define char-case-delta 
  (- (char->ascii #\a) (char->ascii #\A)))

(define (char-upcase c)
  (if (char-lower-case? c)
      (ascii->char (- (char->ascii c) char-case-delta))
      c))

(define (char-downcase c)
  (if (char-upper-case? c)
      (ascii->char (+ (char->ascii c) char-case-delta))
      c))

(define (char-ci-compare pred)
  (lambda (c1 c2) (pred (char-upcase c1) (char-upcase c2))))
(define char-ci=? (char-ci-compare char=?))
(define char-ci<? (char-ci-compare char<?))
(define char-ci<=? (char-ci-compare char<=?))
(define char-ci>? (char-ci-compare char>?))
(define char-ci>=? (char-ci-compare char>=?))


; Strings

(define (string . rest)
  (list->string rest))

(define (substring s start end)
  (let ((new-string (make-string (- end start) #\space)))
    (do ((i start (+ i 1))
         (j 0 (+ j 1)))
        ((= i end) new-string)
      (string-set! new-string j (string-ref s i)))))

(define (string-append  . strings)
  (let ((len (reduce (lambda (s n) (+ (string-length s) n)) 0 strings)))
    (let ((new-string (make-string len #\space)))
      (let loop ((s strings)
		 (i 0))
	(if (null? s)
	    new-string
	    (let* ((string (car s))
		   (l (string-length string)))
	      (do ((j 0 (+ j 1))
		   (i i (+ i 1)))
		  ((= j l) (loop (cdr s) i))
		(string-set! new-string i (string-ref string j)))))))))

(define (string->list v)
  (let ((z (string-length v)))
    (do ((i (- z 1) (- i 1))
         (l '() (cons (string-ref v i) l)))
        ((< i 0) l))))

(define (list->string l)
  (let ((v (make-string (length l) #\space)))
    (do ((i 0 (+ i 1))
         (l l (cdr l)))
        ((null? l) v)
      (string-set! v i (car l)))))

; comes from low-level package ...
;(define (string-copy s)
;  (let ((z (string-length s)))
;    (let ((copy (make-string z #\space)))
;      (let loop ((i 0))
;        (cond ((= i z) copy)
;              (else
;               (string-set! copy i (string-ref s i))
;               (loop (+ i 1))))))))

(define (string-fill! v x)
  (let ((z (string-length v)))
    (do ((i 0 (+ i 1)))
        ((= i z) (unspecific))
      (string-set! v i x))))

(define (make-string=? char=?)
  (lambda (s1 s2)
    (let ((z (string-length s1)))
      (and (= z (string-length s2))
	   (let loop ((i 0))
	     (cond ((= i z) #t)
		   ((char=? (string-ref s1 i) (string-ref s2 i))
		    (loop (+ i 1)))
		   (else #f)))))))

;(define string=?    (make-string=? char=?))  -- VM implements this
(define string-ci=? (make-string=? char-ci=?))

(define (make-string<? char<? char=?)
  (lambda (s1 s2)
    (let ((z1 (string-length s1))
	  (z2 (string-length s2)))
      (let ((z (min z1 z2)))
	(let loop ((i 0))
	  (if (= i z)
	      (< z1 z2)
	      (let ((c1 (string-ref s1 i))
		    (c2 (string-ref s2 i)))
		(or (char<? c1 c2)
		    (and (char=? c1 c2)
			 (loop (+ i 1)))))))))))

(define string<?    (make-string<? char<? char=?))
(define string-ci<? (make-string<? char-ci<? char-ci=?))

(define (string>? s1 s2) (string<? s2 s1))
(define (string<=? s1 s2) (not (string>? s1 s2)))
(define (string>=? s1 s2) (not (string<? s1 s2)))

(define (string-ci>? s1 s2) (string-ci<? s2 s1))
(define (string-ci<=? s1 s2) (not (string-ci>? s1 s2)))
(define (string-ci>=? s1 s2) (not (string-ci<? s1 s2)))

; Vectors

(define (vector . l)
  (list->vector l))

(define (vector->list v)
  (do ((i (- (vector-length v) 1) (- i 1))
       (l '() (cons (vector-ref v i) l)))
      ((< i 0) l)))

(define (list->vector l)
  (let ((v (make-vector (length l) #f)))
    (do ((i 0 (+ i 1))
         (l l (cdr l)))
        ((null? l) v)
      (vector-set! v i (car l)))))

(define (vector-fill! v x)
  (let ((z (vector-length v)))
    (do ((i 0 (+ i 1)))
        ((= i z) (unspecific))
      (vector-set! v i x))))

; Control features

(define (map proc first . rest)
  (if (null? rest)
      (map1 proc first)
      (map2+ proc first rest)))

(define (map1 proc l)
  ;; (reduce (lambda (x l) (cons (proc x) l)) '() l)
  (if (null? l)
      '()
      (cons (proc (car l)) (map1 proc (cdr l)))))

(define (map2+ proc first rest)
  (if (or (null? first)
	  (any null? rest))
      '()
      (cons (apply proc (cons (car first) (map1 car rest)))
	    (map2+ proc (cdr first) (map1 cdr rest)))))

(define (for-each proc first . rest)
  (let loop ((first first) (rest rest))
    (if (or (null? first)
	    (any null? rest))
	(unspecific)
	(begin (apply proc (cons (car first) (map car rest)))
	       (loop (cdr first) (map cdr rest))))))


; Promises.

(define-syntax delay
  (syntax-rules ()
    ((delay ?exp) (make-promise (lambda () ?exp)))))

(define (make-promise thunk-then-result)
  (let ((already-run? #f)
	(started? #f))
    (lambda ()
      (cond ((not already-run?)
	     (if started? (warn "recursive force" thunk-then-result))
	     (set! started? #t)
             (set! thunk-then-result (thunk-then-result))
             (set! already-run? #t)))
      thunk-then-result)))

(define (force promise)
  (promise))
