Advertisement
Guest User

Untitled

a guest
Apr 19th, 2019
147
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Racket 34.76 KB | None | 0 0
  1. #lang racket
  2. (require eopl)
  3. (require racket/string); string-trim
  4. #|--------------------INTEGRANTES---------------------------
  5.  Diana Sofía Navas   1629571
  6.  Luis David Restrepo 1427086
  7.  Walter Santacruz    1630645
  8.  Víctor Vargas       1842274
  9.  ----------------------------------------------------------|#
  10.  
  11. (define lexical-spec
  12. '((white-sp (whitespace) skip)
  13.   (comment ("#" (arbno (not #\newline))) skip)
  14.   (identifier ((arbno "@") letter (arbno (or letter digit "_" "?" "=" ))) symbol)
  15.   (number (digit (arbno digit)) number)
  16.   (number ("-" digit (arbno digit)) number)
  17.   (text ("\"" (or letter whitespace)
  18.               (arbno (or letter digit whitespace ":" "?" "=" "'")) "\"") string)
  19.   )
  20. )
  21.  
  22. (define grammar-spec
  23.   '( ;;Representa un programa de ruby    
  24.      (ruby-program ("ruby" exp-batch "end") a-program)
  25.      ;; Parte 2: Ruby con objetos
  26.      ;; cambiar a: (ruby-program ("ruby" (arbno class-decl) exp-batch "end") a-program)
  27.      
  28.      ;;Exp-batch: Representa una cerradura de expresiones
  29.      (exp-batch (expression (arbno expression)) a-batch)
  30.  
  31.      ;;Expresión:
  32.      (expression (simple-exp) a-simple-exp)
  33.      ;Declare-exp: al menos uno o más identificadores (deben inicializarse en 'nil)
  34.      (expression ("declare" identifier (arbno "," identifier) ";") declare-exp)
  35.      ;Puts-exp: al menos un valor compuesto para imprimir
  36.      (expression ("puts" (separated-list comp-value ",") ";") puts-exp)
  37.  
  38.      (expression ("if" comp-value (arbno "then") exp-batch
  39.                        (arbno "elsif" comp-value (arbno "then") exp-batch)
  40.                        (arbno "else" exp-batch) "end") if-exp)
  41.      
  42.      (expression ("unless" comp-value (arbno "then")
  43.                            exp-batch
  44.                            (arbno "else" exp-batch) "end") unless-exp)
  45.  
  46.      (expression ("while" comp-value (arbno "do") exp-batch "end") while-exp)
  47.      (expression ("until" comp-value (arbno "do") exp-batch "end") until-exp)
  48.  
  49.      (expression ("for" identifier "in" comp-value (arbno "do") exp-batch "end") for-exp)
  50.  
  51.      (expression ("def" identifier "(" (separated-list identifier ",") ")"
  52.                   exp-batch                  
  53.                   "end") function-exp)
  54.      (expression ("return" comp-value ";") return-exp)
  55.  
  56.      ;;Expresión simple
  57.      (simple-exp (simple-value complement ";") val-exp)
  58.      
  59.      ;;Complemento
  60.      (complement ("=" comp-value calls) assign)
  61.      (complement (assign-op comp-value calls) assign-and)
  62.      (complement (calls) comp-calls)
  63.  
  64.      ;;Calls
  65.      ;; 0 o muchas llamadas
  66.      (calls ((arbno call)) some-calls)
  67.  
  68.      ;;Call
  69.      (call (arguments) arguments-call)
  70.      ;; (call ("." identifier arguments) a-method-call) ;; Parte 2: Ruby con Objetos
  71.  
  72.      ;;Argumentos
  73.      ;; llamar una función puede tener 0 argumentos o muchos
  74.      (arguments ("(" (separated-list comp-value ",") ")") some-arguments)
  75.      ;; almenos 1 argumento para llamar acceder a un elemento en un arreglo
  76.      ;; máximo 2, ejemplo: a=[1,2,3]; a[1] #output 2; a[1,2] #output [2,3];
  77.      ;;                    a[1,2,3] #output Error
  78.      (arguments ("[" comp-value (arbno "," comp-value) "]") arr-arguments)
  79.  
  80.      ;;Valores compuestos
  81.      (comp-value (value) a-value)
  82.      (comp-value (un-op comp-value) unop-value)
  83.      
  84.      (value (simple-value) a-s-val)
  85.      (value ("(" comp-value val-compl ")") compl-val)
  86.  
  87.      ;;Complemento para valores
  88.      ;; llamadas a un valor:
  89.      ;; Ejemplo: sirve para ("hola"+(mundo())) donde mundo() retorna "mundo"
  90.      (val-compl (calls) val-call)
  91.      ;; operacion inorden con otro valor
  92.      (val-compl (bin-op comp-value) binop-val)
  93.  
  94.      ;; Valores simples
  95.      (simple-value (identifier) id-val)
  96.      (simple-value (number) int-val)
  97.      (simple-value (text) str-val)
  98.      (simple-value ("true") true-val)
  99.      (simple-value ("false") false-val)
  100.      (simple-value ("nil") nil-val)
  101.      ;; arreglo con 0 o muchos valores
  102.      (simple-value ("["(separated-list comp-value ",")"]") arr-val)
  103.      
  104.      ;;Operacion Inorden
  105.      (bin-op ("+") add)
  106.      (bin-op ("-") diff)
  107.      (bin-op ("*") mult)
  108.      (bin-op ("/") div)
  109.      (bin-op ("%") mod)
  110.      (bin-op ("**") pow)
  111.      (bin-op (">") great)
  112.      (bin-op (">=") great-eq)
  113.      (bin-op ("<") less)
  114.      (bin-op ("<=") less-eq)
  115.      (bin-op ("==") equal)
  116.      (bin-op ("!=") not-equal)
  117.      (bin-op ("and") and-op)
  118.      (bin-op ("&&") and-op)
  119.      (bin-op ("or") or-op)
  120.      (bin-op ("||") or-op)
  121.      ;;Rangos:
  122.      ;; Solo admite 2 argumentos, no se puede operar más de 1 vez
  123.      ;;Inclusivo: va hasta el limite superior
  124.      (bin-op ("..") in-range)
  125.      ;;Exclusivo: va hasta un step antes del limite superior
  126.      (bin-op ("...") ex-range)
  127.      ;; Ejemplo: (1..5) => (1 2 3 4 5)
  128.      ;; Ejemplo: (1...5) => (1 2 3 4)
  129.      ;; Ejemplo: ((1..5) .. 6) => Error
  130.      (bin-op ("step") st-range)
  131.      ;; Ejemplo: ((1..5) step 2) => (1 3 5)
  132.      ;; Ejemplo: ((1..5) step -1) => Error
  133.      ;; Ejemplo: ((-1..-5) step -2) => (-1 -3 -5)
  134.      ;; Ejemplo: ((1..-5) step 2) => Error
  135.      
  136.      ;;Operación asignación
  137.      (assign-op ("+=") add-eq)
  138.      (assign-op ("-=") diff-eq)
  139.      (assign-op ("*=") mult-eq)
  140.      (assign-op ("/=") div-eq)
  141.      (assign-op ("**=") pow-eq)
  142.  
  143.      ;;Operación unitaria
  144.      (un-op ("not") not-op)
  145.      (un-op ("!") not-op)    
  146.   )
  147. )
  148.  
  149. ;Construidos automáticamente:
  150. (sllgen:make-define-datatypes lexical-spec grammar-spec)
  151.  
  152. (define show-the-datatypes
  153.   (lambda () (sllgen:list-define-datatypes lexical-spec grammar-spec)))
  154.  
  155. ;*******************************************************************************************
  156. ;Parser, Scanner, Interfaz
  157.  
  158. ;El FrontEnd (Análisis léxico (scanner) y sintáctico (parser) integrados)
  159.  
  160. (define scan&parse
  161.   (sllgen:make-string-parser lexical-spec grammar-spec))
  162.  
  163. ;El Analizador Léxico (Scanner)
  164.  
  165. (define scan
  166.   (sllgen:make-string-scanner lexical-spec grammar-spec))
  167.  
  168. ;El Interpretador (FrontEnd + Evaluación + señal para lectura )
  169.  
  170. (define interpretador
  171.   (sllgen:make-rep-loop  "--> "
  172.     (lambda (pgm) (eval-program pgm))
  173.     (sllgen:make-stream-parser
  174.       lexical-spec
  175.       grammar-spec)))
  176.  
  177. ;*******************************************************************************************
  178. ;*******************************************************************************************
  179. ;Procedimientos
  180. (define-datatype procval procval?
  181.   (closure
  182.    (ids (list-of symbol?))
  183.    (body exp-batch?)
  184.    (env environment?)
  185.    ))
  186.  
  187. ;apply-procedure: evalua el cuerpo de un procedimientos en el ambiente extendido correspondiente
  188. (define apply-procedure
  189.   (lambda (proc args env)
  190.     (cases procval proc
  191.       (closure (ids body env)
  192.                (eval-proc-batch body (extend-env ids args env))))))
  193.  
  194. ;*******************************************************************************************
  195.  
  196. (define (eval-program pgm)
  197.   (cases ruby-program pgm
  198.     (a-program (a-batch) (eval-exp-batch a-batch (empty-env)))
  199.     )
  200.   )
  201.  
  202. (define is-last-exp-a-func
  203.   (lambda (exps)  
  204.     (if (empty? exps)
  205.         #f
  206.         (if (empty? (cdr exps))
  207.             (if (is-function-exp? (car exps))
  208.                 (get-function-name (car exps))
  209.                 #f)            
  210.             (is-last-exp-a-func (cdr exps))))))
  211.  
  212. (define (get-function-name exp)
  213.   (cases expression exp
  214.     (function-exp (name ids batch) name)
  215.     (else "")))
  216.  
  217. (define (eval-exp-batch batch env)
  218.   (cases exp-batch batch
  219.     (a-batch (exp exps) (let ((result (eval-expressions (cons exp exps) env)))
  220.                           (if (or (environment? result) (void? result))
  221.                               (let ((is-func (is-last-exp-a-func (cons exp exps))))
  222.                                 (if (eqv? is-func #f)
  223.                                     (begin (display "=> ") 'nil)
  224.                                     is-func))
  225.                               result)))))
  226.  
  227. (define (eval-proc-batch batch env)
  228.   (cases exp-batch batch
  229.     (a-batch (exp exps)        
  230.               (eval-expressions (cons exp exps) env))))
  231.  
  232. (define (is-return-exp? exp)
  233.   (cases expression exp
  234.     (return-exp (comp-value) #t)
  235.     (else #f)))
  236.  
  237. (define (is-function-exp? exp)
  238.   (cases expression exp
  239.     (function-exp (name ids batch) #t)
  240.     (else #f)))
  241.  
  242. (define (eval-expressions exps env)
  243.  (if (or (empty? (cdr exps)) (is-return-exp? (car exps)))                
  244.      (eval-expression (car exps) env)    
  245.      (let ((next-env (eval-expression (car exps) env)))
  246.        (if (environment? next-env) (eval-expressions (cdr exps) next-env)
  247.            (eval-expressions (cdr exps) env)))))
  248.  
  249. (define (eval-expression exp env)
  250.   (cases expression exp
  251.     (a-simple-exp (simple-exp) (eval-simple-exp simple-exp env))
  252.  
  253.     (declare-exp (id ids) (extend-env (cons id ids) (map (lambda (x) "nil") (cons id ids)) env))
  254.    
  255.     (puts-exp (vals)
  256.               (for-each (lambda (arg)
  257.                           (if (check-apply-env env arg) (pretty-display (apply-env env arg))
  258.                           (pretty-display arg)))
  259.                         (map (lambda(x) (eval-comp-value x env)) vals)))
  260.  
  261.     (if-exp (if-comp if-batch elsif-comps elsif-batchs else-batch) (if (eqv? "true" (eval-comp-value if-comp env))
  262.                                                                        (eval-exp-batch if-batch env)
  263.                                                                        (if (or (empty? elsif-comps) (empty? elsif-batchs))
  264.                                                                            (if (empty? else-batch)
  265.                                                                                (void)
  266.                                                                                (eval-exp-batch (car else-batch) env))
  267.                                                                            (eval-expression (if-exp (car elsif-comps) (car elsif-batchs) (cdr elsif-comps) (cdr elsif-batchs) else-batch) env))))
  268.  
  269.     (unless-exp (comp-bool batch else-batch) (if (eqv? "false" (eval-comp-value comp-bool env))
  270.                                                  (eval-exp-batch batch env)
  271.                                                  (if (empty? else-batch)
  272.                                                      (void)
  273.                                                      (eval-exp-batch (car else-batch) env))))
  274.  
  275.     (function-exp (name ids batch) (a-recursive-env name ids batch env))
  276.      
  277.     (while-exp (comp-bool batch) (if (eqv? "true" (eval-comp-value comp-bool env))
  278.                                      (let ((new-env(eval-exp-batch batch env)))
  279.                                        (if (environment? new-env)
  280.                                            (eval-expression (while-exp comp-bool batch) new-env)
  281.                                            (eval-expression (while-exp comp-bool batch) env)))
  282.                                      (void)))
  283.  
  284.     (until-exp (comp-bool batch) (if (eqv? "false" (eval-comp-value comp-bool env))
  285.                                      (let ((new-env(eval-exp-batch batch env)))
  286.                                        (if (environment? new-env)
  287.                                            (eval-expression (until-exp comp-bool batch) new-env)
  288.                                            (eval-expression (until-exp comp-bool batch) env)))
  289.                                      (void)))  
  290.  
  291.     (return-exp (comp-value) (eval-comp-value comp-value env))
  292.  
  293.     (for-exp (id comp-value exp-batch)
  294.              (for-each (lambda (x)
  295.                          (eval-exp-batch exp-batch (extend-env (list id) (list x) env)))
  296.                        (eval-comp-value comp-value env)))
  297.    
  298.     (else "TO DO")))
  299.  
  300. (define (eval-simple-exp s-exp env)
  301.   (cases simple-exp s-exp
  302.     (val-exp (simple-value complement) (apply-complement simple-value complement env))))
  303.  
  304. (define (eval-calls-args cls left-value env)
  305.   (cases calls cls
  306.     (some-calls (calls) (if (empty? calls)
  307.                             '()
  308.                             (cons (eval-call (car calls) left-value env)
  309.                                   (eval-calls-args (some-calls (cdr calls)) left-value env))))))
  310.  
  311. (define eval-calls
  312.   (lambda (cls left-value env)
  313.     (let ((args (eval-calls-args cls left-value env))
  314.           (left-value-evaluated (if (simple-value? left-value)
  315.                                     (apply-env env (eval-simple-value left-value env))
  316.                                     (eval-comp-value left-value env))))      
  317.         (if (empty? args)
  318.           (if (symbol? left-value-evaluated)
  319.               (apply-env env left-value-evaluated)
  320.               left-value-evaluated)
  321.           (if (procval? left-value-evaluated)
  322.               (apply-procedure left-value-evaluated (car args) env)
  323.               (let ((result (encontrar left-value-evaluated args)))             ;AQUI VA LO DE ARREGLOS  
  324.                 (if (and (eqv? (length result) 1) (not (list? (car result))))
  325.                     (car result)
  326.                     result)))))))
  327.              
  328.  
  329. (define (is-comp-calls-empty cls env)
  330.   (cases calls cls
  331.     (some-calls (cls) (empty? cls))                            
  332.     (else "")))
  333.  
  334. (define (apply-complement s-val compl env)
  335.   (cases complement compl
  336.     (assign (comp-value calls)
  337.             (let ((id (apply-env-ref env (eval-simple-value s-val env))) (val (eval-calls calls comp-value env)))
  338.               (begin                
  339.                 (setref! id val)
  340.                 val)))                    
  341.  
  342.     (assign-and (assign-op comp-value calls)
  343.                 (let ((left-val-ref (apply-env-ref env (eval-simple-value s-val env)))
  344.                       (right-val (eval-calls calls comp-value env)))
  345.                   (let ((result (apply-assign assign-op (deref left-val-ref) right-val)))
  346.                     (begin
  347.                       (setref! left-val-ref result)
  348.                       result))))  
  349.     (comp-calls (calls) (eval-calls calls s-val env))))                                        
  350.  
  351. (define (eval-comp-value c-value env)
  352.   (cases comp-value c-value
  353.     (a-value (value) (eval-value value env))
  354.     (unop-value (un-op comp-value) (eval-un-op (eval-comp-value comp-value env)))))
  355.  
  356. (define eval-un-op
  357.   (lambda (val)
  358.     (cond
  359.       ((eqv? val "true") "false")
  360.       ((eqv? val "false") "true")
  361.       (else (eopl:error 'eval-un-op "Not a bool")))))      
  362.  
  363. (define (eval-value a-value env)
  364.   (cases value a-value
  365.     (a-s-val (simple-value)(if (symbol? (eval-simple-value simple-value env))
  366.                                (apply-env env (eval-simple-value simple-value env))
  367.                                (eval-simple-value simple-value env)))
  368.     (compl-val (comp-value val-compl) (eval-val-compl comp-value val-compl env))))
  369.  
  370. (define (eval-val-compl comp-value v-compl env)
  371.   (cases val-compl v-compl
  372.     (val-call (calls) (eval-calls calls comp-value env))
  373.     (binop-val (bin-op comp-v) (apply-op bin-op (list (eval-comp-value  comp-value env) (eval-comp-value comp-v env))))))
  374.  
  375. (define (eval-call cl s-val env)
  376.   (cases call cl
  377.     (arguments-call (arguments) (eval-args arguments s-val env))
  378.     (else "")))
  379.  
  380. (define (eval-args args s-val env)
  381.   (cases arguments args
  382.     (some-arguments (comp-values) (if (simple-value? s-val)                                    
  383.                                       (let ((proc (apply-env env (eval-simple-value s-val env))))                                        
  384.                                         (if (procval? proc)
  385.                                             (map (lambda (x) (eval-comp-value x env)) comp-values)
  386.                                             (eopl:error 'Error "Can't apply args to ~s" proc)))                                      
  387.                                       (let ((proc (eval-comp-value s-val env)))
  388.                                         (if (procval? proc)
  389.                                             (map (lambda (x) (eval-comp-value x env)) comp-values)
  390.                                             (eopl:error 'Error "Can't apply args to ~s" proc)))))
  391.                          
  392.     (arr-arguments (comp-value comp-values) (map (lambda (x) (eval-comp-value x env)) (cons comp-value comp-values)))))
  393.  
  394. (define (eval-simple-value s-val env)
  395.   (cases simple-value s-val
  396.     (id-val  (identifier)  identifier)
  397.     (int-val (number) number)
  398.     (str-val (text) (string-trim text "\""))
  399.     (true-val  () "true")
  400.     (false-val () "false")
  401.     (nil-val   () "nil")
  402.     (arr-val   (comp-value) (map (lambda (x) (eval-comp-value x env)) comp-value))))
  403.  
  404. (define (apply-op op args)
  405.   (cases bin-op op
  406.      (add ()  (operacion args 'suma))
  407.      (diff () (- (car args) (cadr args)))
  408.      (mult () (operacion args 'mult))
  409.      (div () (/ (car args) (cadr args)))
  410.      (mod () (modulo (car args) (cadr args)))
  411.      (pow ()(expt (car args) (cadr args)))
  412.      (great () (if (> (car args) (cadr args)) "true" "false"))
  413.      (great-eq () (if (>= (car args) (cadr args)) "true" "false"))
  414.      (less () (if (< (car args) (cadr args)) "true" "false"))
  415.      (less-eq () (if (<= (car args) (cadr args)) "true" "false"))
  416.      (equal () (if (equal? (car args) (cadr args)) "true" "false"))
  417.      (not-equal () (if (not(equal? (car args) (cadr args))) "true" "false"))
  418.      (and-op () (if (and (eval-bool (car args)) (eval-bool (cadr args))) "true" "false"))
  419.      (or-op () (if (or (eval-bool (car args)) (eval-bool (cadr args))) "true" "false"))
  420.      (in-range () (rango (car args) (cadr args) 'in))
  421.      (ex-range () (rango (car args) (cadr args) 'ex))
  422.      (st-range () (steps (car args) (cadr args)))))
  423.  
  424. (define eval-bool
  425.   (lambda (val)
  426.     (if (eqv? val "true") #t #f)))
  427.  
  428. (define (apply-assign op arg1 arg2)
  429.   (cases assign-op op
  430.     (add-eq () (+ arg1 arg2))
  431.     (diff-eq () (- arg1 arg2))
  432.     (mult-eq () (* arg1 arg2))
  433.     (div-eq () (/ arg1 arg2))
  434.     (pow-eq () (expt arg1 arg2))))
  435.    
  436. #|Función que opera seguún el tipo de dato que contenga la lista|#
  437. (define (operacion lista sys)
  438.   (cond
  439.     [(equal? lista '()) "Error"]
  440.     #|Si mi lista de args son puras cadenas entonces sé que su suma equivale a concatenar ambos|#
  441.     [(and (string? (car lista)) (string? (cadr lista)) (eq? sys 'suma))
  442.  
  443.      ;---AQUÍ LO QUE HAGO ES LIMPIAR MI CADENA DE ESTO: #\"
  444.      (list->string(eliminar(string->list
  445.      (string-append (car lista) (cadr lista)))))]
  446.     ;---------------------------------------------------
  447. #|Si el simbolo es 'mult tengo que verificar que almenos uno de los elemenos sea un número para saber
  448. cuantas veces repetir mi cadena|#
  449.     [(or
  450.       (and (string? (car lista)) (number? (cadr lista)) (eq? sys 'mult))
  451.       (and (number? (car lista)) (string? (cadr lista)) (eq? sys 'mult)))
  452.  
  453.      ;---AQUÍ LO QUE HAGO ES LIMPIAR MI CADENA DE ESTO: #\"
  454.       (list->string(eliminar(string->list(mul (car lista) (cadr lista)))))]
  455.     ;---------------------------------------------------
  456.    
  457.     #|Si no se cumple que almenos uno sea cadena entonces hay que verificar si ambos son números. Así,
  458. ya se trate de una suma o una multiplicación, los puedo operar de manera común y corriente|#
  459.     [(and (number? (car lista)) (number? (cadr lista)))
  460.              (if (eq? sys 'suma) (+ (car lista) (cadr lista))
  461.                                  (* (car lista) (cadr lista)))]
  462.     #|Si no cumple ninguna, entonces se trata de un arreglo y debo usar funciones auxiliares|#
  463.     [else (if (eq? sys 'suma)(operar (car lista) (cadr lista))
  464.              (duplicar (car lista) (cadr lista)))
  465.      ]))
  466.  
  467. #|Duplica el contenido de una lista n veces|#
  468. (define (duplicar lista n)
  469.   (cond
  470.     [(eq? '() lista) '()]
  471.     [(= n 0)'()]
  472.     [else (append lista (duplicar lista (- n 1)))]))
  473.  
  474. #|Suma dos arreglos teniendo en cuenta la manera en que son recibidos|#
  475. (define (operar lista1 lista2)
  476.   (cond
  477.     [(and (equal? lista1 '()) (equal? lista2 '())) '()]
  478.     [(append (list (+ (car lista1)
  479.                       (car lista2)))
  480.              (operar (cdr lista1)
  481.                      (cdr lista2)))]))
  482.  
  483. #|MULTIPLICAR CADENAS|#
  484. #|Esta función crea una sola cadena que realmente es una cadena repetida n veces|#
  485. (define (mul cadena n)
  486.   (cond
  487.     [(and (number? cadena) (string? n)) (mul n cadena)]
  488.     [(= n 0) ""]
  489.     [(string-append cadena (mul cadena (- n 1)))]))
  490.  
  491. #|ELIMINAR DIAGONALES DEL TEXTO|#
  492. #|dado a que las cadenas son acompañadas por un #\" entonces hago esta función para eliminarlas y devolver una
  493. cadena más limpia|#
  494. (define (eliminar lista)
  495.   (cond
  496.     [(eq? '() lista)'()]
  497.     [(eq? (car lista) #\")(append (eliminar (cdr lista)))]
  498.    [else (append (list(car lista)) (eliminar (cdr lista)))]))
  499.  
  500. #|Encontrar:
  501.  Debo partir de la siguiente premisa para entender lo que debo hacer:
  502.  Hay dos posibilidades cuando tratamos de obtener un valor de un arreglo.
  503. a)El rango siempre será una lista de longitud 2. Dado a que su naturaleza es tener un inicio y un final.
  504. ;-------------------POSIBILIDADES 1-----------------
  505. (define lista1 (list (list (list 1 2) 3) 4));<----arreglo(longitud 2)=[[[1,2],3],4]
  506. (define lista4 (list (list 0) (list 0) (list 0)))  ;<----lista de rangos de longitud 1)= arreglo[0][0]
  507. ;-------------------POSIBILIDADES 2-----------------
  508. (define lista2 (list(list 1 2 3 4)));<----arreglo (longitud 1)=[1,2,3,4]
  509. (define lista3 (list (list 0 3)));<-------rango   (longitud 2)= arreglo[0,3]
  510. |#
  511. #|Función encontrar, encuentra un dato dentro de un arreglo.|#
  512. (define (encontrar lis-vals lis-pos)
  513.  (cond
  514. #|Si alguna no es de longitud uno, lo que equivale a un arreglo de posibles arreglos y una posición compuesta
  515. (arreglo[in][end]), entonces usamos la función general con ambas listas|#
  516.    [(not (or (= 1 (length lis-vals)) (= 1(length lis-pos)))) (comp-range-array lis-vals lis-pos)]
  517.    
  518.    #|Si la condición anterior no se cumple, estaremos hablando de que ambas son listas simples o sencillas
  519. (un arreglo de sólo números un llamado a posición que va de in a end sin más). Por esto, llamaremos a
  520. simple-range-array que recibe un inicio, un final, una lista y un ac (ac será sólo con propósitos comparativos).
  521. Por lo tanto, invocaremos tal función de la siguiente manera:
  522. inicio = primer valor de la lista lis-pos (array[0,2]->'('(0 2)))->0)
  523. final  = segundo valor de la lista lis-pos(array[0,2]->'('(0 2)))->2)(Si estoy haciendo array[0] entonces end=in)
  524. lista  = (car lis-vals)-->(car(list lis-vals))
  525. ac     = (car lis-vals)-->(car(list lis-vals))|#
  526.    [else (simple-range-array (caar lis-pos) (if (= 1 (length(car lis-pos)))
  527.                                          (caar lis-pos) (cadar lis-pos)) lis-vals lis-vals)]))
  528.  
  529. #|Arreglo simple, posición simple|#
  530. (define (simple-range-array in end lis ac)
  531.  (cond
  532.    #|Tenemos que verificar que in no sea negativo porque tal posición no existe y además debemos verificar que
  533. end no sea mayor que la máxima posición de la lista (dado a que la lista la estaremos modificando por motivos de
  534. recursión, usaremos ac)|#
  535.    [(or (< in 0)  (> end (- (length ac) 1))) "span class="kw1"> Error"]
  536.    #|Si la lista está vacía devolvemos vación ya que el propósito de esta función es retornar una lista|#
  537.    [(empty? lis) '()]
  538.    #|Nuestro punto de parada es cuando nuestro inicio llegue a su final, entonces devolveremos lo que contenga
  539.      el dato en esa posición de la lista ingresada. Si lo que devuelve es una lista, la entregamos tal como está
  540.      si lo que devuelve es un dato diferente a lista, devolvemos el dato dentro de una lista.|#
  541.    [(= in end)  (if (list? (list-ref lis in)) (list-ref lis in) (list (list-ref lis in)))]
  542.    #|Mientras que el punto de parada no se cumpla, concatenaremos el dato que se encuentra en la posición in
  543.      con la recurisón de simple-range-array pero ahora in se aumentará en uno y su end,lis y ac serán los mismos.|#
  544.    [else (append (list (list-ref lis in)) (simple-range-array (+ in 1) end lis ac))]))
  545.  
  546.  
  547. #|Cuando no se trate de un arreglo simple y por lo tanto de una llamado a posicionamiento simple, acudiremos a
  548. la función encon que recibe dos listas|#
  549. (define (encon lista1 lista2)
  550.  (cond
  551. #|Punto de parada: cuando la lista a la cual le estamos buscando un número, termine siendo el mismo entonces
  552. devolverlo.|#
  553.    [(number? lista1) lista1]
  554. #|Mientras ningun punto de parada se cumpla seguiremos haciendo llamado a encontrar (para que se encargue de decidir
  555. si hemos llegado a un punto donde las lista1 es simple (arreglo sencillo) o seguimos teniendo un arreglo compuesto).
  556. pero la lista donde buscaremos el dato será el producto de hacer list-ref con la lista1 intacta y como posición tendremos
  557. el primer dato, del primer dato de lista2 -arreglo[0][1]-->'('(0)'(1))--> 0-. Como lista2 pasaremos el resto de esta.|#
  558.    [else (encontrar (list-ref lista1 (caar lista2)) (cdr lista2))]))
  559.  
  560. #|Función bool me regresa una lista de dos booleanos las cuales me servirán de indicador para saber si mi llamado
  561. es compuesto o no.|#
  562. (define (bool lista)
  563.  (map (lambda (x) (= 1 (length x)))lista))
  564.  
  565.  
  566. #|----------------------Funcion evalua arreglos compuestos-------------------------------------------------|#
  567. (define (comp-range-array lista1 lista2)
  568.  (cond
  569. #|Si bool devuelve una lista con dos datos de tipo #true entonces estaremos hablando de una lista de posiciones compuesta
  570. con llamado a dato en una sola posición (Ej: array[0][0]). Entonces,haremos llamado a encon con ambas listas|#
  571.    [(and (equal? #t (car (bool lista2)))
  572.          (equal? #t (cadr (bool lista2)))) (encon lista1 lista2)]
  573.    
  574. #|Si no devuelve una lista de sólo true's quiere decir que tenemos un arreglo compuesto y llamado de posición compuesto
  575. que desea sacar una fragmento de un arreglo contenido sobre otro.
  576. Ej: array = [[1,2,3],4,5]; puts(array[0][0,2]);
  577. Por lo tanto llamaremos a la función principal encontrar para que se encargue de evaluar de nuevo todo y sacar
  578. lo necesario a través de las diferentes funciones auxiliares|#
  579.    
  580.    [else (encontrar (encon lista1 lista2) (cdr lista2))]))
  581.  
  582. ; eval-simple-value s-val env (cases simple-value s-val (id-val ...) (num-val ...) (true-val ...))
  583. ;   evalúa un valor simple, comprende los casos desde id-val hasta arr-val
  584. ;   para el caso de id-val se debe hacer apply-env
  585.  
  586. #|Función que dependiendo de el simbolo, realiza una lista excluyente o incluyente en un rango origen-destino|#
  587. (define (rango origen destino sym)
  588.  (cond
  589.    #|Me aseguro que origen y destino sean números para no cometer errores de operación|#
  590.    [(not(or(number? origen) (number? destino))) "span class="kw1"> Error"]
  591.    [(equal? sym 'in) (inclu origen destino)]
  592.    [(equal? sym 'ex) (exclu origen destino)]
  593.    #|Si no se digita el sym permitido, debo mostrar error|#
  594.    [else "span class="kw1"> Error"]))
  595.  
  596. #|La función inclu realiza una lista que va desde origen hasta destino siendo el punto de parada cuando origen
  597. sea igual a destino|#
  598. (define (inclu origen destino)
  599.  (cond
  600.    [(or (list? origen) (list? destino))"span class="kw1"> Error"]
  601.    [(= origen destino) (list origen)]
  602.    [(< origen destino) (append (list origen) (inclu (+ origen 1) destino))]
  603.    [(> origen destino) (reverse(inclu destino origen))]))
  604.  
  605. #|La función exclu realiza una lista que va desde origen hasta destino siendo el punto de parada cuando origen
  606. sea igual a destino pero con la diferencia que el punto de para devuelve vacio.|#
  607. (define (exclu origen destino)
  608.  (cond
  609.    [(or (list? origen) (list? destino))"span class="kw1"> Error"]
  610.    [(= origen destino) empty]
  611.    [(< origen destino) (append (list origen) (exclu(+ origen 1) destino))]
  612.    [(> origen destino) (append (list origen) (exclu(- origen 1) destino))]))
  613.  
  614. #|Para explicar pasos, tendremos de ejemplo lo siguiente:
  615. lista       = '(1 2 3 4 5)
  616. paso        = 2
  617. lis-compare = lista|#
  618. (define (pasos lista paso lis-compare)
  619.  (cond
  620.    [(empty? lista) '()];<----Si la lista está vacía, devolver vacío (Dado a que la función retorna una lista).
  621.    
  622.    [(or(and (< (car lis-compare) (last lis-compare))                   ;|  Verificar que sea posible hacer paso con la
  623.             (> 0 paso))(and (> (car lis-compare) (last lis-compare))   ;|->lista dada. Dado a que la lista se verá
  624.                             (< 0 paso)))(eopl:error 'Step "bad step")] ;|  afectada por recursión usamos lis-compare
  625.    
  626.    [else (append (list(car lista)) ;->Concatenar el primero de la lista (1)...
  627.                  (pasos (if (positive? paso)                                              ;|...con el llamado recursivo
  628.                             (if(> paso (length lista)) '() (list-tail lista paso))        ;|->pero ahora lista será
  629.                      (if(> (* -1 paso) (length lista)) '() (list-tail lista (* -1 paso))));|'(3 4 5) gracias a list-tail
  630.                         paso                                                              ;| paso será el mismo
  631.                         lis-compare))]))                                                  ;|y lis-compare será la misma.
  632.  
  633. (define (steps lista paso)
  634.  (pasos lista paso lista))
  635.  
  636. ;*******************************************************************************************
  637. ;Referencias
  638. (define-datatype reference reference?
  639.  (a-ref (position integer?)
  640.         (vec vector?)))
  641.  
  642. (define deref
  643.  (lambda (ref)
  644.    (primitive-deref ref)))
  645.  
  646. (define primitive-deref
  647.  (lambda (ref)
  648.    (cases reference ref
  649.      (a-ref (pos vec)
  650.             (vector-ref vec pos)))))
  651.  
  652. (define setref!
  653.  (lambda (ref val)
  654.    (primitive-setref! ref val)))
  655.  
  656. (define primitive-setref!
  657.  (lambda (ref val)
  658.    (cases reference ref
  659.      (a-ref (pos vec)
  660.             (vector-set! vec pos val)))))
  661.  
  662. ;*******************************************************************************************
  663. ;*******************************************************************************************
  664. ;Ambientes
  665.  
  666. ;definición del tipo de dato ambiente
  667. (define-datatype environment environment?
  668.  (empty-env-record)
  669.  (extended-env-record
  670.   (syms (list-of symbol?))
  671.   (vec  vector?)
  672.   (env environment?)))
  673.  
  674. (define scheme-value? (lambda (v) #t))
  675.  
  676. ;empty-env:      -> enviroment
  677. ;función que crea un ambiente vacío
  678. (define empty-env  
  679.  (lambda ()
  680.    (empty-env-record)))       ;llamado al constructor de ambiente vacío
  681.  
  682.  
  683. ;extend-env: <list-of symbols> <list-of numbers> enviroment -> enviroment
  684. ;función que crea un ambiente extendido
  685. (define extend-env
  686.  (lambda (syms vals env)
  687.    (extended-env-record syms (list->vector vals) env)))
  688.  
  689. ;extend-env-recursively: <list-of symbols> <list-of <list-of symbols>> <list-of expressions> environment -> environment
  690. ;función que crea un ambiente extendido para procedimientos recursivos
  691. (define extend-env-recursively
  692.  (lambda (proc-names idss bodies old-env)
  693.    (let ((len (length proc-names)))
  694.      (let ((vec (make-vector len)))
  695.        (let ((env (extended-env-record proc-names vec old-env)))
  696.          (for-each
  697.            (lambda (pos ids body)
  698.              (vector-set! vec pos (closure ids body env)))
  699.            (iota len) idss bodies)
  700.          env)))))
  701.  
  702. ; |Ambiente recursivo para un solo procedimiento
  703.  
  704. (define (a-recursive-env a-proc-name ids body env)
  705.  (let ((vec (make-vector 1)))
  706.    (let ((env (extended-env-record (list a-proc-name) vec env)))
  707.          (vector-set! vec 0 (closure ids body env))
  708.          env)
  709.    )
  710.  )
  711.  
  712. ;iota: number -> list
  713. ;función que retorna una lista de los números desde 0 hasta end
  714. (define iota
  715.  (lambda (end)
  716.    (let loop ((next 0))
  717.      (if (>= next end) '()
  718.        (cons next (loop (+ 1 next)))))))
  719.  
  720. ;función que busca un símbolo en un ambiente
  721. (define apply-env
  722.  (lambda (env sym)  
  723.    (deref (apply-env-ref env sym))))
  724.  
  725. (define apply-env-ref
  726.  (lambda (env sym)
  727.    (cases environment env
  728.      (empty-env-record () (eopl:error 'Error "undefined local variable or method ~s" sym))
  729.      (extended-env-record (syms vals env)
  730.                           (let ((pos (rib-find-position sym syms)))
  731.                             (if (number? pos)
  732.                                 (a-ref pos vals)
  733.                                 (apply-env-ref env sym)))))))
  734.  
  735. ;valida un simbolo en el ambiente
  736. ;función que busca un símbolo en un ambiente
  737. (define check-apply-env
  738.  (lambda (env sym)
  739.    (check-apply-env-ref env sym)))
  740.  
  741. (define check-apply-env-ref
  742.  (lambda (env sym)
  743.    (cases environment env
  744.      (empty-env-record ()
  745.                        #f)
  746.      (extended-env-record (syms vals env)
  747.                           (let ((pos (rib-find-position sym syms)))
  748.                             (if (number? pos)
  749.                                 #t
  750.                                 (check-apply-env-ref env sym)))))))
  751.  
  752. ;*******************************************************************************************
  753. ;*******************************************************************************************
  754. ;Ambiente inicial
  755.  
  756. (define (init-env) (empty-env))
  757. ;*******************************************************************************************
  758. ;*******************************************************************************************
  759. ;Funciones Auxiliares
  760.  
  761. ; funciones auxiliares para encontrar la posición de un símbolo
  762. ; en la lista de símbolos de un ambiente
  763.  
  764. (define rib-find-position
  765.  (lambda (sym los)
  766.    (list-find-position sym los)))
  767.  
  768. (define list-find-position
  769.  (lambda (sym los)
  770.    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))
  771.  
  772. (define list-index
  773.  (lambda (pred ls)
  774.    (cond
  775.      ((null? ls) #f)
  776.      ((pred (car ls)) 0)
  777.      (else (let ((list-index-r (list-index pred (cdr ls))))
  778.              (if (number? list-index-r)
  779.                (+ list-index-r 1)
  780.                #f))))))
  781.  
  782. ;*******************************************************************************************
  783. ;*******************************************************************************************
  784.  
  785. ;;Función que retorna una lista dado un inicio, un final, y un incremento
  786. (define iota-range
  787.  (lambda (start end step)
  788.    (cond [(or
  789.            (and (< start end) (> 0 step))
  790.            (and (> start end) (< 0 step)))
  791.           (eopl:error 'Step "bad step")]
  792.          [else
  793.           (let loop ((next start))
  794.             (if (= 0 (abs (- next end)))
  795.                 (list next)
  796.                 (cons next (loop (+ next step)))))]
  797.          )
  798.    ))
  799.  
  800. ; #Ejemplos:
  801. ; > (eval-range (inclusive 1 10 1))
  802. ; (1 2 3 4 5 6 7 8 9 10)
  803. ; > (eval-range (exclusive 1 10 1))
  804. ; (1 2 3 4 5 6 7 8 9)
  805. ; > (eval-range (inclusive 1 -10 1))
  806. ; . . Step: bad step
  807. ; > (eval-range (inclusive -1 10 -1))
  808. ; . . Step: bad step
  809.  
  810. ;ruby def fact(n) if (n == 0) then return 1; else puts "el valor de n es ",n; return (n * (fact ((n - 1)))); end end puts "el factorial de 5 es", (fact(5)); end
  811. ;*******************************************************************************************
  812. ;*******************************************************************************************
  813. ; ruby def print(v) puts v; end print(2); end
  814. (interpretador)
  815.  
  816. ;ruby def fact(n) if (n == 0) then return 1; else return (n*(fact((n - 1)))); end end fact(5); end
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement