;; Scheme-Ausdrücke als Datentyp

(define variable?
  (lambda (form)
    (symbol? form)))

(define variable-name
  (lambda (form)
    form))

;; Kombinationen lassen sich an ihrem Operator erkennen

(define make-combination-predicate
  (lambda (name)
    (lambda (form)
      (and (pair? form)
	   (eq? name (car form))))))

(define define? (make-combination-predicate 'define))

(define define-variable-name
  (lambda (form)
    (car (cdr form))))

(define define-expression
  (lambda (form)
    (car (cdr (cdr form)))))

(define quote? (make-combination-predicate 'quote))

(define quote-constant
  (lambda (form)
    (car (cdr form))))

(define literal?
  (lambda (form)
    (or (quote? form)
	(and (not (pair? form))
	     (not (variable? form))))))

(define literal-constant
  (lambda (form)
    (if (quote? form)
	(quote-constant form)
	form)))

(define lambda? (make-combination-predicate 'lambda))

(define lambda-parameters
  (lambda (form)
    (car (cdr form))))

(define lambda-body
  (lambda (form)
    (car (cdr (cdr form)))))

(define if? (make-combination-predicate 'if))

(define if-test
  (lambda (form)
    (car (cdr form))))

(define if-consequent
  (lambda (form)
    (car (cdr (cdr form)))))

(define if-alternative
  (lambda (form)
    (car (cdr (cdr (cdr form))))))

(define set!? (make-combination-predicate 'set!))

(define set!-variable-name
  (lambda (form)
    (car (cdr form))))

(define set!-expression
  (lambda (form)
    (car (cdr (cdr form)))))

(define begin? (make-combination-predicate 'begin))

(define begin-expressions
  (lambda (form)
    (cdr form)))

;; Eine Applikation ist eine Kombination, die zu keiner der oberen
;; Kombinationssorten gehört

(define application-operator
  (lambda (form)
    (car form)))

(define application-operands
  (lambda (form)
    (cdr form)))

;; Primitive und ganz normale Werte

(define primitive-value-type (make-type 'primitive-value))
  
(define make-primitive-value
  (lambda (value)
    (make-typed-object primitive-value-type value)))

(define value-primitive?
  (typed-object-predicate primitive-value-type))

(define primitive-value
  (lambda (value)
    (typed-object-value primitive-value-type value)))

(define ordinary-value-type (make-type 'ordinary-value))

(define make-ordinary-value
  (lambda (value)
    (make-typed-object ordinary-value-type value)))

(define value-ordinary?
  (typed-object-predicate ordinary-value-type))

(define ordinary-value
  (lambda (value)
    (typed-object-value ordinary-value-type value)))

;; Prozeduren werden durch Closures repräsentiert

(define closure-type (make-type 'closure))

(define make-closure
  (lambda (parameters body environment)
    (make-typed-object
     closure-type
     (cons (cons parameters body)
	   environment))))

(define closure-parameters
  (lambda (closure)
    (car (car (typed-object-value closure-type closure)))))

(define closure-body
  (lambda (closure)
    (cdr (car (typed-object-value closure-type closure)))))

(define closure-environment
  (lambda (closure)
    (cdr (typed-object-value closure-type closure))))

;; Umgebungen

(define environment-type (make-type 'environment))

(define make-environment
  (lambda (frame enclosing-environment)
    (make-typed-object
     environment-type
     (cons frame enclosing-environment))))

(define environment-frame
  (lambda (environment)
    (car (typed-object-value environment-type environment))))

(define environment-enclosing-environment
  (lambda (environment)
    (cdr (typed-object-value environment-type environment))))

;; Frames bestehen aus Bindungen

(define frame-type (make-type 'frame))

(define make-frame
  (lambda (bindings)
    (make-typed-object frame-type
		       (cons bindings #f))))

(define frame-bindings
  (lambda (frame)
    (car (typed-object-value frame-type frame))))

;; Eine Bindung ist ein Paar aus Variablenname und Wert

(define extend-frame!
  (lambda (frame name value)
    (let ((frame-cell (typed-object-value frame-type frame)))
      (set-car! frame-cell
		(cons (cons name value) (car frame-cell))))))

(define frame-lookup-binding
  (lambda (frame name)
    (assoc name (frame-bindings frame))))

(define environment-lookup-binding
  (lambda (environment name)
    (let ((try-here (frame-lookup-binding (environment-frame environment) name)))
      (if try-here
	  try-here
	  (let ((enclosing-environment
		 (environment-enclosing-environment environment)))
	    (if enclosing-environment
		(environment-lookup-binding enclosing-environment name)
		#f))))))

(define environment-lookup
  (lambda (environment name)
    (let ((stuff (environment-lookup-binding environment name)))
      (if stuff
	  (cdr stuff)
	  #f))))

(define environment-mutate-binding!
  (lambda (environment name new-value)
    (let ((binding (environment-lookup-binding environment name)))
      (set-cdr! binding new-value))))

;; Die globale Umgebung enthält einige Primitiva

(define make-global-environment
  (lambda ()
    (make-environment
      (make-frame
       (list
	(cons '+ (make-primitive-value +))
	(cons '* (make-primitive-value *))
	(cons '= (make-primitive-value =))
	(cons '- (make-primitive-value -))))
      #f)))

;; Der Wert von Zuweisungen

(define unspecific-value
 (make-ordinary-value 'unspecific))

;; EVALUATE wertet einen Ausdruck in bezug auf eine Umgebung aus

(define evaluate
  (lambda (expression environment)
    (cond
     ((literal? expression)
      (make-ordinary-value (literal-constant expression)))
     ((variable? expression)
      (environment-lookup environment
			  (variable-name expression)))
     ((if? expression)
      (if (ordinary-value (evaluate (if-test expression) environment))
	  (evaluate (if-consequent expression) environment)
	  (evaluate (if-alternative expression) environment)))
     ((set!? expression)
      (environment-mutate-binding! environment
				   (set!-variable-name expression)
				   (evaluate (set!-expression expression)
					     environment))
      unspecific-value)
     ((begin? expression)
      (letrec ((loop (lambda (expressions last-value)
		       (if (null? expressions)
			   last-value
			   (loop (cdr expressions)
				 (evaluate (car expressions) environment))))))
	(loop (begin-expressions expression) #f)))
     ((lambda? expression)
      (make-ordinary-value
       (make-closure (lambda-parameters expression)
		     (lambda-body expression)
		     environment)))
     (else ;; Prozeduranwendung
      (let ((procedure (evaluate (application-operator expression)
				 environment))
	    (parameter-values
	     (map (lambda (operand)
		    (evaluate operand environment))
		  (application-operands expression))))
	(apply-procedure procedure parameter-values))))))

;; APPLY-PROCEDURE wertet eine Prozedur auf die Werte der Operanden
;; der Anwendung an

(define apply-procedure
  (lambda (procedure parameter-values)
    (if (value-primitive? procedure)
	(make-ordinary-value
	 (apply (primitive-value procedure)
		(map ordinary-value parameter-values)))
	(let* ((closure (ordinary-value procedure))
	       (parameters (closure-parameters closure))
	       (new-frame
		(make-frame (zip parameters parameter-values)))
	       (environment
		(make-environment new-frame
				  (closure-environment closure))))
	  (evaluate (closure-body closure) environment)))))

;; ZIP macht aus zwei Listen eine Liste von Paaren

(define zip
  (lambda (list-1 list-2)
    (letrec
	((loop
	  (lambda (list-1 list-2 reverse-result)
	    (if (null? list-1)
		(reverse reverse-result)
		(loop (cdr list-1) (cdr list-2)
		      (cons (cons (car list-1) (car list-2))
			    reverse-result))))))
      (loop list-1 list-2 '()))))

;; Ein Programm besteht aus Definitionen und Ausdrücken

(define evaluate-program
  (lambda (forms)
    (let ((global-environment (make-global-environment)))
      (letrec
	  ((loop
	    (lambda (forms reverse-values)
	      (cond
	       ((null? forms) (reverse reverse-values))
	       ((define? (car forms))
		(process-definition (define-variable-name (car forms))
				    (define-expression (car forms))
				    global-environment)
		(loop (cdr forms) reverse-values))
	       (else
		(let ((value (evaluate (car forms) global-environment)))
		  (loop (cdr forms) (cons value reverse-values))))))))
	(map ordinary-value
	     (loop forms '()))))))

;; Eine Definition erweitert eine Umgebung

(define process-definition
  (lambda (name expression environment)
    (let ((value (evaluate expression environment)))
      (extend-frame!
       (environment-frame environment)
       name
       value))))