;; A self-interpreter for our first-order Scheme dialect.

(define (run defs name args)
  (call (map-def.name defs) defs name args))

(define (map-def.name defs)
  (if (null? defs)
      '()
      (cons (def.name (car defs))
            (map-def.name (cdr defs)))))

(define (def.name def)   (caadr def))
(define (def.params def) (cdadr def))
(define (def.body def)   (caddr def))

(define (call dn dv name args)
  (apply-def dn dv (lookup-def name dn dv) args))

(define (apply-def dn dv def args)
  (evaluate dn dv (def.params def) args (def.body def)))

(define (evaluate dn dv vn vv e)
  (if (literal? e)
      (literal-value e)
      (if (symbol? e)
	  (lookup e vn vv)
	  (eval-combo dn dv vn vv (car e) (cdr e)))))

(define (literal? e)
  (if (pair? e)
      (eq? (car e) 'quote)
      (if (boolean? e) #t
          (if (char? e) #t
              (if (number? e) #t
                  (string? e))))))

(define (literal-value e)
  (if (pair? e)
      (cadr e)
      e))

(define (eval-combo dn dv vn vv tag es)
  (if (eq? tag 'if)
      (if (evaluate dn dv vn vv (car es))
	  (evaluate dn dv vn vv (cadr es))
	  (evaluate dn dv vn vv (caddr es)))
      (if (memq tag dn)
	  (call dn dv tag (eval-operands dn dv vn vv es))
	  (call-primitive tag (eval-operands dn dv vn vv es)))))

(define (call-primitive tag vv)
  (if (eq? tag 'boolean?) (boolean? (car vv))
  (if (eq? tag 'char?) (char? (car vv))
  (if (eq? tag 'exact?) (exact? (car vv))
  (if (eq? tag 'inexact?) (inexact? (car vv))
  (if (eq? tag 'integer?) (integer? (car vv))
  (if (eq? tag 'number?) (number? (car vv))
  (if (eq? tag 'pair?) (pair? (car vv))
  (if (eq? tag 'string?) (string? (car vv))
  (if (eq? tag 'symbol?) (symbol? (car vv))
  (if (eq? tag 'vector?) (vector? (car vv))
  (if (eq? tag 'floor) (floor (car vv))
  (if (eq? tag 'round) (round (car vv))
  (if (eq? tag 'exact->inexact) (exact->inexact (car vv))
  (if (eq? tag 'inexact->exact) (inexact->exact (car vv))
  (if (eq? tag 'integer->char) (integer->char (car vv))
  (if (eq? tag 'char->integer) (char->integer (car vv))
  (if (eq? tag 'car) (car (car vv))
  (if (eq? tag 'cdr) (cdr (car vv))
  (if (eq? tag 'string->symbol) (string->symbol (car vv))
  (if (eq? tag 'symbol->string) (symbol->string (car vv))
  (if (eq? tag 'string-length) (string-length (car vv))
  (if (eq? tag 'vector-length) (vector-length (car vv))
  (if (eq? tag 'sqrt) (sqrt (car vv))
  (if (eq? tag 'exp) (exp (car vv))
  (if (eq? tag 'log) (log (car vv))
  (if (eq? tag 'sin) (sin (car vv))
  (if (eq? tag 'cos) (cos (car vv))
  (if (eq? tag 'tan) (tan (car vv))
  (if (eq? tag 'asin) (asin (car vv))
  (if (eq? tag 'acos) (acos (car vv))
  (if (eq? tag 'atan) (atan (car vv))
  (if (eq? tag 'null?) (null? (car vv))
  (if (eq? tag 'not) (not (car vv))
  (if (eq? tag 'char-whitespace?) (char-whitespace? (car vv))
  (if (eq? tag 'reverse) (reverse (car vv))
  (if (eq? tag 'length) (length (car vv))
  (if (eq? tag 'complex?) (complex? (car vv))
  (if (eq? tag 'real?) (real? (car vv))
  (if (eq? tag 'rational?) (rational? (car vv))
  (if (eq? tag 'list?) (list? (car vv))
  (if (eq? tag 'abs) (abs (car vv))
  (if (eq? tag 'positive?) (positive? (car vv))
  (if (eq? tag 'zero?) (zero? (car vv))
  (if (eq? tag 'negative?) (negative? (car vv))
  (if (eq? tag 'odd?) (odd? (car vv))
  (if (eq? tag 'even?) (even? (car vv))
  (if (eq? tag 'ceiling) (ceiling (car vv))
  (if (eq? tag 'truncate) (truncate (car vv))
  (if (eq? tag 'char-numeric?) (char-numeric? (car vv))
  (if (eq? tag 'char-lower-case?) (char-lower-case? (car vv))
  (if (eq? tag 'char-upper-case?) (char-upper-case? (car vv))
  (if (eq? tag 'char-alphabetic?) (char-alphabetic? (car vv))
  (if (eq? tag 'char-upcase) (char-upcase (car vv))
  (if (eq? tag 'char-downcase) (char-downcase (car vv))
  (if (eq? tag 'list->vector) (list->vector (car vv))
  (if (eq? tag 'vector->list) (vector->list (car vv))
  (if (eq? tag 'list->string) (list->string (car vv))
  (if (eq? tag 'string->list) (string->list (car vv))
  (if (eq? tag 'string-copy) (string-copy (car vv))
  (if (eq? tag 'newline) (newline (car vv))
  (if (eq? tag 'caar) (caar (car vv))
  (if (eq? tag 'cdar) (cdar (car vv))
  (if (eq? tag 'cadr) (cadr (car vv))
  (if (eq? tag 'cddr) (cddr (car vv))
  (if (eq? tag 'caaar) (caaar (car vv))
  (if (eq? tag 'cdaar) (cdaar (car vv))
  (if (eq? tag 'cadar) (cadar (car vv))
  (if (eq? tag 'cddar) (cddar (car vv))
  (if (eq? tag 'caadr) (caadr (car vv))
  (if (eq? tag 'cdadr) (cdadr (car vv))
  (if (eq? tag 'caddr) (caddr (car vv))
  (if (eq? tag 'cdddr) (cdddr (car vv))
  (if (eq? tag 'caaaar) (caaaar (car vv))
  (if (eq? tag 'cdaaar) (cdaaar (car vv))
  (if (eq? tag 'cadaar) (cadaar (car vv))
  (if (eq? tag 'cddaar) (cddaar (car vv))
  (if (eq? tag 'caadar) (caadar (car vv))
  (if (eq? tag 'cdadar) (cdadar (car vv))
  (if (eq? tag 'caddar) (caddar (car vv))
  (if (eq? tag 'cdddar) (cdddar (car vv))
  (if (eq? tag 'caaadr) (caaadr (car vv))
  (if (eq? tag 'cdaadr) (cdaadr (car vv))
  (if (eq? tag 'cadadr) (cadadr (car vv))
  (if (eq? tag 'cddadr) (cddadr (car vv))
  (if (eq? tag 'caaddr) (caaddr (car vv))
  (if (eq? tag 'cdaddr) (cdaddr (car vv))
  (if (eq? tag 'cadddr) (cadddr (car vv))
  (if (eq? tag 'cddddr) (cddddr (car vv))
  (if (eq? tag 'eq?) (eq? (car vv) (cadr vv))
  (if (eq? tag 'eqv?) (eqv? (car vv) (cadr vv))
  (if (eq? tag 'string=?) (string=? (car vv) (cadr vv))
  (if (eq? tag 'modulo) (modulo (car vv) (cadr vv))
  (if (eq? tag 'quotient) (quotient (car vv) (cadr vv))
  (if (eq? tag 'remainder) (remainder (car vv) (cadr vv))
  (if (eq? tag 'cons) (cons (car vv) (cadr vv))
  (if (eq? tag 'string-ref) (string-ref (car vv) (cadr vv))
  (if (eq? tag 'vector-ref) (vector-ref (car vv) (cadr vv))
  (if (eq? tag 'expt) (expt (car vv) (cadr vv))
  (if (eq? tag 'atan) (atan (car vv) (cadr vv))
  (if (eq? tag 'assq) (assq (car vv) (cadr vv))
  (if (eq? tag 'assv) (assv (car vv) (cadr vv))
  (if (eq? tag 'char<?) (char<? (car vv) (cadr vv))
  (if (eq? tag 'char<=?) (char<=? (car vv) (cadr vv))
  (if (eq? tag 'char=?) (char=? (car vv) (cadr vv))
  (if (eq? tag '+) (+ (car vv) (cadr vv))
  (if (eq? tag '-) (- (car vv) (cadr vv))
  (if (eq? tag '*) (* (car vv) (cadr vv))
  (if (eq? tag '/) (/ (car vv) (cadr vv))
  (if (eq? tag '<) (< (car vv) (cadr vv))
  (if (eq? tag '<=) (<= (car vv) (cadr vv))
  (if (eq? tag '=) (= (car vv) (cadr vv))
  (if (eq? tag 'make-vector) (make-vector (car vv) (cadr vv))
  (if (eq? tag 'make-string) (make-string (car vv) (cadr vv))
  (if (eq? tag 'number->string) (number->string (car vv) (cadr vv))
  (if (eq? tag 'string->number) (string->number (car vv) (cadr vv))
  (if (eq? tag 'equal?) (equal? (car vv) (cadr vv))
  (if (eq? tag 'append) (append (car vv) (cadr vv))
  (if (eq? tag 'list-ref) (list-ref (car vv) (cadr vv))
  (if (eq? tag 'list-tail) (list-tail (car vv) (cadr vv))
  (if (eq? tag 'memq) (memq (car vv) (cadr vv))
  (if (eq? tag 'memv) (memv (car vv) (cadr vv))
  (if (eq? tag 'member) (member (car vv) (cadr vv))
  (if (eq? tag 'assoc) (assoc (car vv) (cadr vv))
  (if (eq? tag 'gcd) (gcd (car vv) (cadr vv))
  (if (eq? tag 'lcm) (lcm (car vv) (cadr vv))
  (if (eq? tag '>) (> (car vv) (cadr vv))
  (if (eq? tag '>=) (>= (car vv) (cadr vv))
  (if (eq? tag 'min) (min (car vv) (cadr vv))
  (if (eq? tag 'max) (max (car vv) (cadr vv))
  (if (eq? tag 'char>=?) (char>=? (car vv) (cadr vv))
  (if (eq? tag 'char>?) (char>? (car vv) (cadr vv))
  (if (eq? tag 'char-ci<?) (char-ci<? (car vv) (cadr vv))
  (if (eq? tag 'char-ci<=?) (char-ci<=? (car vv) (cadr vv))
  (if (eq? tag 'char-ci=?) (char-ci=? (car vv) (cadr vv))
  (if (eq? tag 'char-ci>=?) (char-ci>=? (car vv) (cadr vv))
  (if (eq? tag 'char-ci>?) (char-ci>? (car vv) (cadr vv))
  (if (eq? tag 'string<?) (string<? (car vv) (cadr vv))
  (if (eq? tag 'string<=?) (string<=? (car vv) (cadr vv))
  (if (eq? tag 'string>?) (string>? (car vv) (cadr vv))
  (if (eq? tag 'string>=?) (string>=? (car vv) (cadr vv))
  (if (eq? tag 'string-ci<?) (string-ci<? (car vv) (cadr vv))
  (if (eq? tag 'string-ci<=?) (string-ci<=? (car vv) (cadr vv))
  (if (eq? tag 'string-ci=?) (string-ci=? (car vv) (cadr vv))
  (if (eq? tag 'string-ci>=?) (string-ci>=? (car vv) (cadr vv))
  (if (eq? tag 'string-ci>?) (string-ci>? (car vv) (cadr vv))
  (if (eq? tag 'string-append) (string-append (car vv) (cadr vv))
  (if (eq? tag 'error) (error (car vv) (cadr vv))
  (if (eq? tag 'substring) (substring (car vv) (cadr vv) (caddr vv))
  (error "Unknown primitive" (cons tag vv))
  ))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
  )))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))

(define (eval-operands dn dv vn vv es)
  (if (null? es)
      '()
      (cons (evaluate dn dv vn vv (car es))
	    (eval-operands dn dv vn vv (cdr es)))))

(define (lookup x vn vv)
  (if (null? vn)
      (error "Unbound" x)
      (if (eq? x (car vn))
          (car vv)
          (lookup x (cdr vn) (cdr vv)))))

(define (lookup-def name dn dv)
  (if (null? dn)
      (error "Unknown function" name)
      (if (eq? name (car dn))
          (car dv)
          (lookup-def name (cdr dn) (cdr dv)))))
