;; Die ersten drei Zeilen dieser Datei wurden von DrRacket eingefügt. Sie enthalten Metadaten
;; über die Sprachebene dieser Datei in einer Form, die DrRacket verarbeiten kann.
#reader(lib "DMdA-advanced-reader.ss" "deinprogramm")((modname mze) (read-case-sensitive #f) (teachpacks ()) (deinprogramm-settings #(#f constructor repeating-decimal #t #t none datum #f ())))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Ein Auswerter für MiniScheme, das folgende Konstrukte enthält:
; 
; Definitionen:
; (define variable ausdruck)
;
; Ausdrücke: Zahlen, Variablen, quotierte Ausdruecke und
;  (prozedur exprs)
;  (if bedingung ausdruck1 ausdruck2)
;  (letrec bindungen ausdruck)
;  (begin exprs)
;  (lambda parameter ausdruck)
;  (set! variable ausdruck)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Nützliche Abkürzungen

; Berechne das 2. Element einer Liste
(: second ((list-of %a) -> %a))
(define second
  (lambda (xs) (first (rest xs))))

; Berechne das 3. Element einer Liste
(: third ((list-of %a) -> %a))
(define third
  (lambda (xs) (first (rest (rest xs)))))

; Berechne das 4. Element einer Liste
(: fourth ((list-of %a) -> %a))
(define fourth
  (lambda (xs) (first (rest (rest (rest xs))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Darstellung der betrachteten Ausdrücke

; Ein Ausdruck ist eins der Folgenden:
; - eine Zahl (number)
; - ein Wahrheitswert (boolean)
; - ein String (string)
; - ein Symbol (symbol)
; - eine Liste von Ausdrücken
; - ein Prozedurobjekt (procedure)
(define expression
  (signature
    (mixed number
           boolean
           string
           symbol
           (list-of expression)
           procedure)))

;;; Nützliches Prädikat:
;;; Ist das Argument eine Liste mit einem gegebenen ersten Symbol?
(: list-with-tag? (symbol any -> boolean))
(define list-with-tag?
  (lambda (symbol expr)
    (if (cons? expr)
        (equal? (first expr) symbol)
        #f)))


;;; Quotierungen

(: quoted? (expression -> boolean))
(define quoted?
  (lambda (expr) (list-with-tag? 'quote expr)))

(: expression-of-quotation (expression -> expression))
(define expression-of-quotation
  (lambda (expr) (second expr)))


;;; Variablen

(: variable? (expression -> boolean))
(define variable?
  (lambda (expr) (symbol? expr)))


;;; Zuweisungen

(: assignment? (expression -> boolean))
(define assignment?
  (lambda (expr) (list-with-tag? 'set! expr)))

(: assignment-variable (expression -> symbol))
(define assignment-variable
  (lambda (expr) (second expr)))

(: assignment-value (expression -> expression))
(define assignment-value
  (lambda (expr) (third expr)))


;;; Bedingte Ausdrücke: (if bedingung ausdruck1 ausdruck2)

(: if? (expression -> boolean))
(define if?
  (lambda (expr) (list-with-tag? 'if expr)))

(: if-predicate (expression -> expression))
(define if-predicate
  (lambda (expr) (second expr)))

(: if-consequent (expression -> expression))
(define if-consequent
  (lambda (expr) (third expr)))

(: if-alternative (expression -> expression))
(define if-alternative
  (lambda (expr) (fourth expr)))


;;; Abstraktionen  (lambda (x y) (+ x (* y 2)))

(: lambda? (expression -> boolean))
(define lambda?
  (lambda (expr) (list-with-tag? 'lambda expr)))

(: lambda-parameters (expression -> (list-of symbol)))
(define lambda-parameters
  (lambda (expr) (second expr)))

(: lambda-body (expression -> expression))
(define lambda-body
  (lambda (expr) (third expr)))

;;; Definitionen  (define x (+ 3 5))

(: definition? (expression -> boolean))
(define definition?
  (lambda (expr) (list-with-tag? 'define expr)))

(: definition-variable (expression -> symbol))
(define definition-variable
  (lambda (expr) (second expr)))

(: definition-value (expression -> expression))
(define definition-value
  (lambda (expr) (third expr)))



;;; Folgen von Ausdrücken: (begin ...)

(: begin? (expression -> boolean))
(define begin?
  (lambda (expr) (list-with-tag? 'begin expr)))

(: begin-actions (expression -> (list-of expression)))
(define begin-actions
  (lambda (expr) (rest expr)))




;;; Lokale Definitionen: (letrec bindings exp)

(: letrec? (expression -> boolean))
(define letrec?
  (lambda (expr) (list-with-tag? 'letrec expr)))

(: letrec-bindings (expression -> (list-of expression)))
(define letrec-bindings
  (lambda (expr) (second expr)))

(: letrec-expression (expression -> expression))
(define letrec-expression
  (lambda (expr) (third expr)))

(: letrec-binding-variable (expression -> symbol))
(define letrec-binding-variable
  (lambda (binding) (first binding)))

(: letrec-binding-expression (expression -> expression))
(define letrec-binding-expression
  (lambda (binding) (second binding)))


;;; Prozeduranwendungen

(: application? (expression -> boolean))
(define application?
  (lambda (expr) (cons? expr)))

(: operator (expression -> expression))
(define operator
  (lambda (expr) (first expr)))

(: operands (expression -> (list-of expression)))
(define operands
  (lambda (expr) (rest expr)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Darstellung von Prozedurobjekten

; Eine benutzerdefiniertes Prozedurobjekt besteht aus
; - einem lambda-Ausdruck (expression)
; - einer zugehörigen Umgebung (environment)
(define-record-procedures compound-procedure
  make-compound-procedure
  compound-procedure?
  (procedure-expression procedure-environment))

(: make-compound-procedure (expression environment -> compound-procedure))
(: compound-procedure? (any -> boolean))
(: procedure-expression (compound-procedure -> expression))
(: procedure-environment (compound-procedure -> environment))

; Parameterliste einer benutzerdefinierten Prozedur
(: procedure-parameters (compound-procedure -> (list-of symbol)))
(define procedure-parameters
  (lambda (proc)
    (lambda-parameters (procedure-expression proc))))

; Rumpf einer benutzerdefinierten Prozedur
(: procedure-body (compound-procedure -> expression))
(define procedure-body
  (lambda (proc)
    (lambda-body (procedure-expression proc))))


; Ein primitive Prozedurobjekt besteht aus
; - dem Namen der Prozedur (symbol)
(define-record-procedures
  primitive-procedure
  make-primitive-procedure
  primitive-procedure?
  (primitive-procedure-name))

(: make-primitive-procedure (symbol -> primitive-procedure))
(: primitive-procedure? (any -> boolean))
(: primitive-procedure-name (primitive-procedure -> symbol))

; Ein Prozedurobjekt ist eins der Folgenden:
; - ein benutzerdefiniertes Prozedurobjekt
; - ein primitives Prozedurobjekt
(define procedure
  (signature (mixed compound-procedure
                    primitive-procedure)))

(: procedure? (any -> boolean))
(define procedure?
  (lambda (x) (or (compound-procedure? x)
                  (primitive-procedure? x))))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Darstellung von Umgebungen

; Eine Umgebung (environment) besteht aus
; - einem (veränderbaren) ersten Rahmen
; - einer Vorgängerumgebung
(define-record-procedures-2
  environment
  make-environment
  environment?
  ((environment-first-frame set-environment-first-frame!)
   environment-ancestor))

; Eine Vorgängerumgebung ist eins der Folgenden:
; - eine leere Umgebung (im Falle der globalen Umgebung)
; - eine Umgebung
(define ancestor-environment
  (signature (mixed empty-list
                    environment)))
                    
(: make-environment (frame ancestor-environment -> environment))
(: environment-first-frame (environment -> frame))
(: set-environment-first-frame! (environment frame -> unspecific))
(: environment-ancestor (environment -> ancestor-environment))


;;; Darstellung von Bindungen

; Eine Bindung besteht aus
; - einer Variablen (symbol)
; - einem (veränderbaren) Ausdruck (expression)
(define-record-procedures-2
   binding
   make-binding
   binding?
   (binding-variable (binding-value set-binding-value!)))

(: make-binding (symbol expression -> binding))
(: binding? (any -> boolean))
(: binding-variable (binding -> symbol))
(: binding-value (binding -> expression))
(: set-binding-value! (binding expression -> unspecific))
   

;;; Darstellung von Bindungsrahmen

; Ein Bindungsrahmen ist eine Liste von Bindungen
(define frame (signature (list-of binding)))

; Erzeuge neuen Bindungsrahmen aus einer Liste von Variablen
; und einer Liste von Ausdrücken
(: make-new-frame ((list-of symbol) (list-of expression) -> frame))
(define make-new-frame
  (lambda (variables values)
    (cond ((and (empty? variables) (empty? values)) empty)
          ((empty? variables)
           (violation "make-new-frame: Zu viele Werte angegeben"))
          ((empty? values)
           (violation "make-new-frame: Zu wenige Werte angegeben"))
          (else
           (cons (make-binding (first variables) (first values))
                 (make-new-frame (rest variables) (rest values)))))))

; Erweitere einen Rahmen um eine neue Bindung
(: add-binding (binding frame -> frame))
(define add-binding
  (lambda (binding frame)
    (cons binding frame)))

; Suche eine Bindung in einem Rahmen.
; Falls diese nicht vorhanden ist, wird die leere Liste
; zurückgegeben
(: binding-in-frame (symbol frame -> (mixed binding empty-list)))
(define binding-in-frame
  (lambda (var bindings)
    (cond ((empty? bindings) empty)
          ((equal? var (binding-variable (first bindings))) 
           (first bindings))
          (else (binding-in-frame var (rest bindings))))))


;;; Operationen auf Umgebungen

; Suche eines Variablenwertes in einer Umgebung
(: lookup-variable-value (symbol environment -> expression))
(define lookup-variable-value
  (lambda (var env)
    (binding-value (binding-in-env var env))))

; Suche eine Bindung in einer Umgebung und melde
; einen Fehler, falls diese Bindung nicht vorhanden ist
(: binding-in-env (symbol environment -> binding))
(define binding-in-env
  (lambda (var env)
    (letrec ((b (binding-in-frame 
                   var
                   (environment-first-frame env))))
      (if (binding? b)
          b
          (letrec ((ancestor (environment-ancestor env)))
            (if (empty? ancestor)
                (violation (string-append
                             (symbol->string var)
                             ": Ungebundene Variable"))
                (binding-in-env var ancestor)))))))

; Erweitere eine Umgebung um neuen Bindungsrahmen mit
; gegebenen Bindungen
(: extend-environment ((list-of symbol) (list-of expression)
                       ancestor-environment -> environment))
(define extend-environment
  (lambda (variables values base-env)
    (make-environment (make-new-frame variables values)
                      base-env)))

; Definiere eine Variable in einer Umgebung
(: define-variable! (symbol expression environment -> unspecific))
(define define-variable!
  (lambda (var value env)
    (letrec ((b (binding-in-frame var
                                  (environment-first-frame env))))
      (if (binding? b)
          (violation (string-append
                       (symbol->string var)
                       ": Redefinition nicht erlaubt!"))
          (set-environment-first-frame!
             env
             (add-binding (make-binding var value)
                          (environment-first-frame env)))))))

; Setze Variablenbindung auf einen neuen Wert
(: set-variable-value!
     (symbol expression environment -> unspecific))
(define set-variable-value!
  (lambda (var value env)
    (set-binding-value! (binding-in-env var env) value)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Implementierung der Auswertungsregeln des Umgebungsmodells:

(: eval (expression environment -> unspecific))
(define eval
  (lambda (expr env)
    (cond ((number?      expr) expr)
          ((boolean?     expr) expr)
          ((string?      expr) expr)
          ((quoted?      expr) (expression-of-quotation expr))
          ((variable?    expr) (lookup-variable-value expr env))
          ((definition?  expr) (eval-definition expr env))
          ((assignment?  expr) (eval-assignment expr env))
          ((lambda?      expr) (make-compound-procedure expr env))
          ((if?          expr) (eval-if expr env))
          ((begin?       expr) (eval-sequence (begin-actions expr) env))
          ((letrec?      expr) (eval-letrec expr env))
          ((application? expr)
           (apply-proc (eval (operator expr) env)
                       (list-of-values (operands expr) env)))
          (else (violation "eval: Unbekannter Ausdruckstyp")))))

; Auswertung einer Definition
(: eval-definition (expression environment -> unspecific))
(define eval-definition
  (lambda (expr env)
    (define-variable!
      (definition-variable expr)
      (eval (definition-value expr) env)
      env)))

; Auswertung einer Zuweisung
(: eval-assignment (expression environment -> unspecific))
(define eval-assignment
  (lambda (expr env)
    (set-variable-value! (assignment-variable expr)
                         (eval (assignment-value expr) env)
                         env)))

; Auswertung eines if-Ausdrucks
(: eval-if (expression environment -> expression))
(define eval-if
  (lambda (expr env)
    (if (true? (eval (if-predicate expr) env))
        (eval (if-consequent expr) env)
        (eval (if-alternative expr) env))))

; Auswertung einer Sequenz von Ausdrücken (begin ...)
(: eval-sequence ((list-of expression) environment -> unspecific))
(define eval-sequence
  (lambda (exprs env)
    (if (empty? (rest exprs)) ; letzter Ausdruck?
        (eval (first exprs) env)
        (begin (eval (first exprs) env)
               (eval-sequence (rest exprs) env)))))

; Auswertung einer Sequenz von Bindungen (in letrec-Ausdrücken)
(: eval-letrec-bindings
    ((list-of expression) environment -> unspecific))
(define eval-letrec-bindings
  (lambda (bindings env)
    (if (empty? bindings)
        empty ; oder ein anderer beliebiger Wert
        (begin
          (define-variable!
            (letrec-binding-variable (first bindings))
            (eval (letrec-binding-expression (first bindings)) env)
            env)
          (eval-letrec-bindings (rest bindings) env)))))

; Auswertung eines letrec-Ausdrucks
(: eval-letrec (expression environment -> expression))
(define eval-letrec
  (lambda (expr env)
    (letrec ((new-env (extend-environment empty empty env)))
      (begin (eval-letrec-bindings (letrec-bindings expr) new-env)
             (eval (letrec-expression expr) new-env)))))

; Auswertung einer Prozeduranwendung
(: apply-proc (procedure (list-of expression) -> expression))
(define apply-proc
  (lambda (procedure arguments)
    (cond ((primitive-procedure? procedure)
           (apply-primitive-procedure procedure arguments))
          ((compound-procedure? procedure)
           (eval (procedure-body procedure)
                 (extend-environment
                    (procedure-parameters procedure)
                    arguments
                    (procedure-environment procedure)))))))

; Auswertung einer Liste von Ausdrücken
(: list-of-values
    ((list-of expression) environment -> (list-of expression)))
(define list-of-values
  (lambda (exprs env)
    (if (empty? exprs)
        empty
        (cons (eval (first exprs) env)
              (list-of-values (rest exprs) env)))))

; Anwendung einer primitiven Prozedur auf Argumente
(: apply-primitive-procedure
    (primitive-procedure (list-of expression) -> expression))
(define apply-primitive-procedure
  (lambda (proc arguments)
    (letrec ((p (primitive-procedure-name proc))
             (arg1 (first arguments)))
      (cond ((equal? p 'first) (first arg1))
            ((equal? p 'rest) (rest arg1))
            ((equal? p 'cons) (cons arg1 (second arguments)))
            ((equal? p 'empty?) (empty? arg1))
            ((equal? p '+) (+ arg1 (second arguments)))
            ((equal? p '-) (- arg1 (second arguments)))
            ((equal? p '*) (* arg1 (second arguments)))
            ((equal? p '/) (/ arg1 (second arguments)))
            ((equal? p '=) (= arg1 (second arguments)))
            ;;** weitere elementare Prozeduren
            (else (violation
                   "apply-primitive-procedure: Unbekannte elementare Prozedur"))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Verwaltung vordefinierter Prozeduren

; Namen der vordefinierten Prozeduren
(: primitive-procedure-names (list-of symbol))
(define primitive-procedure-names
  '(first rest cons empty? + - * / =
      ;** Füge die Namen weiterer elementarer Prozeduren hinzu
      ))

; Objekte der vordefinierten Prozeduren
(: primitive-procedure-objects (list-of primitive-procedure))
(define primitive-procedure-objects
  ; map ist vordefiniert und identisch zu map-list (vgl. Kap 2.3)
  (map (lambda (name) (make-primitive-procedure name))
       primitive-procedure-names))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Der Evaluator als Scheme-Programm

; Erstelle die initiale globale Umgebung
(: prepare-environment (-> environment))
(define prepare-environment
  (lambda ()
    (letrec ((initial-env
              (extend-environment primitive-procedure-names
                                  primitive-procedure-objects
                                  empty)))
      (begin (define-variable! 'empty empty initial-env)
             initial-env))))

; Die globale Umgebung
(: the-global-environment environment)
(define the-global-environment (prepare-environment))


;;; Treiberschleife

(: read-eval-print-loop (-> unspecific))
(define read-eval-print-loop
  (lambda ()
    (begin (write-newline)
           (write-string "MiniScheme> ")
           (letrec ((exp (read)))
             (if (equal? exp 'stop)
                 (write-string "Bye")
                 (begin (write-value (eval exp the-global-environment))
                        (read-eval-print-loop)))))))

; Aufruf der Treiberschleife mit einem Programm, d.h. einer
; initialen Liste von Definitionen:
(: start-program ((list-of expression) -> unspecific))
(define start-program
  (lambda (prog)
    (begin (eval-sequence prog the-global-environment)
           (read-eval-print-loop))))

; Eine Liste von Beispieldefinitionen:
(: example-prog (list-of expression))
(define example-prog
  '((define sq
      (lambda (x) (* x x)))
    (define fac
      (lambda (n) (if (= n 0) 1 (* n (fac (- n 1))))))
    (define make-counter
      (lambda ()
        (letrec ((x 0))
          (lambda () (begin (set! x (+ x 1)) x)))))
    (define z1 (make-counter))
    (define z2 (make-counter))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Ablauf unseres Evaluators mit den Beispieldefinitionen:
; > (eval-sequence example-prog the-global-environment)
;
; Ablauf der REPL mit den Beispieldefinitionen:
; > (start-program example-prog)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Ausgabe eines beliebigen Ausdrucks (dies muss noch definiert werden!!!)
(: write-value (any -> unspecific))
(define write-value (lambda (x) (violation "write-value undefined")))