interpretador_mod

#lang eopl

;******************************************************************************************
;;;;; Interpretador para lenguaje con condicionales, ligadura local y procedimientos

;; La definición BNF para las expresiones del lenguaje:
;;
;;  <program>       ::= <expression>
;;                      <a-program (exp)>
;;  <expression>    ::= <number>
;;                      <lit-exp (datum)>
;;                  ::= <identifier>
;;                      <var-exp (id)>
;;                  ::= <primitive> ({<expression>}*(,))
;;                      <primapp-exp (prim rands)>
;;                  ::= if <expresion> then <expresion> else <expression>
;;                      <if-exp (exp1 exp2 exp23)>
;;                  ::= let {identifier = <expression>}* in <expression>
;;                      <let-exp (ids rands body)>
;;                  ::= proc({<identificador>}*(,)) <expression>
;;                      <proc-exp (ids body)>
;;                  ::= (<expression> {<expression>}*)
;;                      <app-exp proc rands>
;;  <primitive>     ::= + | - | * | add1 | sub1

;******************************************************************************************

;******************************************************************************************
;Especificación Léxica

(define scanner-spec-simple-interpreter
'((white-sp
   (whitespace) skip)
  (comment
   ("%" (arbno (not #\newline))) skip)
  (identifier
   (letter (arbno (or letter digit "?"))) symbol)
  (number
   (digit (arbno digit)) number)
  (number
   ("-" digit (arbno digit)) number)))

;Especificación Sintáctica (gramática)

(define grammar-simple-interpreter
  '((program (expression) a-program)
    (expression (number) lit-exp)
    (expression (identifier) var-exp)
    (expression
     (primitive "(" (separated-list expression ",")")")
     primapp-exp)
    (expression ("if" expression "then" expression "else" expression)
                if-exp)
    (expression ("let" (arbno identifier "=" expression) "in" expression)
                let-exp)
    (expression
        ("atLeast" "(" expression "," (separated-list expression ",") ")" )
        atleast-exp
    )
    (expression
        ("arity" "(" expression  ")" )
        arity-exp
    )
    (expression ("abb" abb "end") bst-exp)
    (abb ("empty-bst") empty)
    (abb ("leaf" "(" number ")") leaf)
    (abb ("node" "(" number "," abb "," abb ")") node)
    (expression ("push" number "to" expression) bst-push-exp) ; Punto 5.2.a) push <number> to <abb>
    (expression ("preorder" expression) preorder-bst-exp)     ; Punto 5.2.b) preorder <abb>
    (expression ("is" number "in" expression) in-bst-exp)     ; Punto 5.2.c) is <number> in <abb>
    ; características adicionales
    (expression ("proc" "(" (separated-list identifier ",") ")" expression)
                proc-exp)
    (expression ( "(" expression (arbno expression) ")")
                app-exp)
    (expression ( "eclipse" "(" identifier ")" )
      eclipse-exp
    )
    ;;;;;;

    (primitive ("+") add-prim)
    (primitive ("-") substract-prim)
    (primitive ("*") mult-prim)
    (primitive ("add1") incr-prim)
    (primitive ("sub1") decr-prim)))


;Tipos de datos para la sintaxis abstracta de la gramática

;Construidos manualmente:

;(define-datatype program program?
;  (a-program
;   (exp expression?)))
;
;(define-datatype expression expression?
;  (lit-exp
;   (datum number?))
;  (var-exp
;   (id symbol?))
;  (primapp-exp
;   (prim primitive?)
;   (rands (list-of expression?)))
;  (if-exp
;   (test-exp expression?)
;   (true-exp expression?)
;   (false-exp expression?))
;  (let-exp
;   (ids (list-of symbol?))
;   (rans (list-of expression?))
;   (body expression?))
;  (proc-exp
;   (ids (list-of symbol?))
;   (body expression?))
;  (app-exp
;   (proc expression?)
;   (args (list-of expression?))))

;
;(define-datatype primitive primitive?
;  (add-prim)
;  (substract-prim)
;  (mult-prim)
;  (incr-prim)
;  (decr-prim))

;Construidos automáticamente:

(sllgen:make-define-datatypes scanner-spec-simple-interpreter grammar-simple-interpreter)

(define show-the-datatypes
  (lambda () (sllgen:list-define-datatypes scanner-spec-simple-interpreter grammar-simple-interpreter)))

;*******************************************************************************************
;Parser, Scanner, Interfaz

;El FrontEnd (Análisis léxico (scanner) y sintáctico (parser) integrados)

(define scan&parse
  (sllgen:make-string-parser scanner-spec-simple-interpreter grammar-simple-interpreter))

;El Analizador Léxico (Scanner)

(define just-scan
  (sllgen:make-string-scanner scanner-spec-simple-interpreter grammar-simple-interpreter))

;El Interpretador (FrontEnd + Evaluación + señal para lectura )

(define interpretador
  (sllgen:make-rep-loop  "--> "
    (lambda (pgm) (eval-program  pgm))
    (sllgen:make-stream-parser
      scanner-spec-simple-interpreter
      grammar-simple-interpreter)))

;*******************************************************************************************
;El Interprete

;eval-program: <programa> -> numero
; función que evalúa un programa teniendo en cuenta un ambiente dado (se inicializa dentro del programa)

(define eval-program
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
                 (eval-expression body (init-env))))))

; Ambiente inicial
;(define init-env
;  (lambda ()
;    (extend-env
;     '(x y z)
;     '(4 2 5)
;     (empty-env))))
(define init-env
    (lambda ()
        (empty-env)
    )
)

;eval-expression: <expression> <enviroment> -> numero
; evalua la expresión en el ambiente de entrada
(define eval-expression
    (lambda (exp env)
        (cases expression exp

            (lit-exp (datum) datum)

            (var-exp (id)
                (if  (procval? (apply-env env id))
                    (list id (apply-env env id))
                    (apply-env env id)
                )
            )

            (primapp-exp (prim rands)
                (let (
                        [args (eval-rands rands env) ]
                    )
                    (apply-primitive prim args)
                )
            )

            (if-exp (test-exp true-exp false-exp)

                (if (true-value? (eval-expression test-exp env  ) )
                    (eval-expression true-exp env)
                    (eval-expression false-exp env)
                )

            )

            (atleast-exp (number-at-least list-of-expressions)

                (define x 0)
                (for-each
                    (lambda (arg)
                        (if (true-value? (eval-expression arg env))
                            (set! x (+ x 1))
                            #f
                        )
                    )
                    list-of-expressions
                )
                (if (or (> x (eval-expression number-at-least env)) (= x (eval-expression number-at-least env)))
                    #t
                    #f
                )

            )

            (arity-exp (proc)
                (if (procval? (eval-expression proc env) )
                    (cases procval (eval-expression proc env )
                        (closure (ids body env)
                            (length ids)
                        )
                    )
                    (eopl:error "No corresponde a un procedimiento")
                )
            )

            (let-exp (ids rands body)
                (let (
                        [args (eval-rands rands env) ]
                    )
                    (eval-expression body (extend-env ids args env))
                )
            )

            (proc-exp (ids body)
                (closure ids body env)
            )

            (app-exp (rator rands)
                (let (
                        [proc (cadr (eval-expression rator env))]
                        [args (eval-rands rands env)]
                    )
                    (if (procval? proc)
                        (cases procval proc
                            (closure (ids body env)
                                (if (= (length ids) (length args))
                                    (apply-procedure proc args)
                                    (apply-procedure (apply-env env (car (eval-expression rator env) )) args)
                                )
                            )
                        )
                        (eopl:error 'eval-expression "Attempt to apply non-procedure ~s" proc)
                    )
                )
            )

            (bst-exp (abb) (if (abb-order? abb) abb (eopl:error 'eval-expression
                                 "Not an ABB")))
            (bst-push-exp (number abb) (abb-insert number (eval-expression abb env))) ; Punto 5.2.a) push <number> to <abb>
            (preorder-bst-exp (abb) (pre-order (eval-expression abb env)))            ; punto 5.2.b) preorder <abb>
            (in-bst-exp (number abb) (in-abb? number (eval-expression abb env)))

            (eclipse-exp (sym)
              (eclipse env sym )
            )

        )
    )
)

; funciones auxiliares para aplicar eval-expression a cada elemento de una
; lista de operandos (expresiones)
(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

;apply-primitive: <primitiva> <list-of-expression> -> numero
(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim () (+ (car args) (cadr args)))
      (substract-prim () (- (car args) (cadr args)))
      (mult-prim () (* (car args) (cadr args)))
      (incr-prim () (+ (car args) 1))
      (decr-prim () (- (car args) 1)))))

;true-value?: determina si un valor dado corresponde a un valor booleano falso o verdadero
(define true-value?
  (lambda (x)
    (not (zero? x))))

;*******************************************************************************************
;Procedimientos
(define-datatype procval procval?
  (closure
   (ids (list-of symbol?))
   (body expression?)
   (env environment?)))

;apply-procedure: evalua el cuerpo de un procedimientos en el ambiente extendido correspondiente
(define apply-procedure
  (lambda (proc args)
    (cases procval proc
      (closure (ids body env)
               (eval-expression body (extend-env ids args env))))))

;*******************************************************************************************
;Ambientes

;definición del tipo de dato ambiente
(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record (syms (list-of symbol?))
                       (vals (list-of scheme-value?))
                       (env environment?)))

(define scheme-value? (lambda (v) #t))

;empty-env:      -> enviroment
;función que crea un ambiente vacío
(define empty-env
  (lambda ()
    (empty-env-record)))       ;llamado al constructor de ambiente vacío


;extend-env: <list-of symbols> <list-of numbers> enviroment -> enviroment
;función que crea un ambiente extendido
(define extend-env
    (lambda (syms vals env)
        (extended-env-record syms vals env)
    )
)

;función que busca un símbolo en un ambiente
(define apply-env
    (lambda (env sym)
        (cases environment env
            (empty-env-record ()
                (eopl:error 'apply-env "No binding for ~s" sym)
            )
            (extended-env-record (syms vals env)
                (let (  (pos (list-find-position sym syms) ) )
                    (if (number? pos)
                        (list-ref vals pos)
                        (apply-env env sym)
                    )
                )
            )
        )
    )
)

(define eclipse
    (lambda (env sym)
        (cases environment env
            (empty-env-record ()
                0
            )
            (extended-env-record (syms vals env)
                (let (  (pos (list-find-position sym syms) ) )
                    (if (number? pos)
                        (+ 1 (eclipse env sym))
                        (+ 0 (eclipse env sym))
                    )
                )
            )
        )
    )
)

;****************************************************************************************
;Funciones Auxiliares

; funciones auxiliares para encontrar la posición de un símbolo
; en la lista de símbolos de unambiente

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

(define list-index
  (lambda (pred ls)
    (cond
      ((null? ls) #f)
      ((pred (car ls)) 0)
      (else (let ((list-index-r (list-index pred (cdr ls))))
              (if (number? list-index-r)
                (+ list-index-r 1)
                #f))))))

;---------------------------------------------------------------------------------------------------------------
; Añadiendo BST al Interpretador - Funciones Auxiliares - Inicio

; Propiedad de orden abb-order-aux?: valida que una determinada raiz
; sea mayor o menor, según operador ingresado, a todos los nodos de un lado
(define abb-order-aux?
  (lambda (op root tree)
    (cases abb tree
      (empty () #t)
      (leaf (value) (op root value))
      (node (value l-node r-node)
            (if (op root value)
                (and (abb-order-aux? op root l-node) (abb-order-aux? op root r-node))
                #f)))))


; Propiedad de orden abb-order?: valida la propiedad de orden de un arbol binario de busqueda
(define abb-order?
  (lambda (tree)
    (cases abb tree
      (empty () #t)
      (leaf (value) #t)
      (node (value l-node r-node)
            (and
             (and (abb-order-aux? > value l-node)
                  (abb-order? l-node))
             (and (abb-order-aux? < value r-node)
                  (abb-order? r-node)))))))


; Funcion abb-insert: inserta un elemento en un ABB, valida la propiedad de orden del ABB
(define abb-insert
  (lambda (elem tree)
    (cond
      [(abb-order? tree) (abb-insert-aux elem tree)]
      [else (eopl:error 'abb-insert "Expected Binary Search Tree, given ~s" tree)])))


; Funcion auxiliar abb-insert-aux: inserta un elemento a un ABB una vez validada su propiedad de orden
(define abb-insert-aux
  (lambda (elem tree)
    (cases abb tree
      (empty () (leaf elem))
      (leaf (value) (if (< elem value)
                        (node value (leaf elem) (empty))
                        (node value (empty) (leaf elem))))
      (node (value l-node r-node) (if (eqv? elem value) tree
                                             (if (< elem value)
                                                 (node value (abb-insert-aux elem l-node) r-node)
                                                 (node value l-node (abb-insert-aux elem r-node))))))))


; Recorrido pre-orden: root-left-right
(define pre-order
  (lambda (tree)
    (cases abb tree
      (empty () '())
      (leaf (value) (list value))
      (node (value l-node r-node) (append (list value) (pre-order l-node) (pre-order r-node))))))


; Verificar si un número (elemento) está en un ABB:
(define in-abb?
  (lambda (number tree)
    (cases abb tree
      (empty () #f)
      (leaf (value) (if (eqv? number value) #t #f))
      (node (value l-node r-node) (if (eqv? number value) #t (if (< number value)
                                                                 (in-abb? number l-node)
                                                                 (in-abb? number r-node)))))))


; Añadiendo BST al Interpretador - Funciones Auxiliares - Final
;---------------------------------------------------------------------------------------------------------------

;******************************************************************************************
;Pruebas

(show-the-datatypes)
just-scan
scan&parse
(just-scan "add1(x)")
(just-scan "add1(   x   )%cccc")
(just-scan "add1(  +(5, x)   )%cccc")
(just-scan "add1(  +(5, %ccccc x) ")
(scan&parse "add1(x)")
(scan&parse "add1(   x   )%cccc")
(scan&parse "add1(  +(5, x)   )%cccc")
(scan&parse "add1(  +(5, %cccc
x)) ")
(scan&parse "if -(x,4) then +(y,11) else *(y,10)")
(scan&parse "let
x = -(y,1)
in
let
x = +(x,2)
in
add1(x)")

(define caso1 (primapp-exp (incr-prim) (list (lit-exp 5))))
(define exp-numero (lit-exp 8))
(define exp-ident (var-exp 'c))
(define exp-app (primapp-exp (add-prim) (list exp-numero exp-ident)))
(define programa (a-program exp-app))
(define una-expresion-dificil (primapp-exp (mult-prim)
                                           (list (primapp-exp (incr-prim)
                                                              (list (var-exp 'v)
                                                                    (var-exp 'y)))
                                                 (var-exp 'x)
                                                 (lit-exp 200))))
(define un-programa-dificil
    (a-program una-expresion-dificil))

(interpretador)