From c5fcf7179a83ef65c86c6a4a390029149e518649 Mon Sep 17 00:00:00 2001 From: Franciszek Malinka Date: Tue, 5 Oct 2021 21:49:54 +0200 Subject: Duzy commit ze smieciami --- Semestr 2/racket/l8z15/solution.bak | 187 ------------------------------------ 1 file changed, 187 deletions(-) delete mode 100644 Semestr 2/racket/l8z15/solution.bak (limited to 'Semestr 2/racket/l8z15/solution.bak') diff --git a/Semestr 2/racket/l8z15/solution.bak b/Semestr 2/racket/l8z15/solution.bak deleted file mode 100644 index cdc84f9..0000000 --- a/Semestr 2/racket/l8z15/solution.bak +++ /dev/null @@ -1,187 +0,0 @@ -#lang racket - -; Do list.rkt dodajemy procedury -; -; Miejsca, ktore sie zmienily oznaczone sa przez !!! - -(provide parse eval) - -; --------- ; -; Wyrazenia ; -; --------- ; - -(struct const (val) #:transparent) -(struct binop (op l r) #:transparent) -(struct var-expr (id) #:transparent) -(struct let-expr (id e1 e2) #:transparent) -(struct if-expr (eb et ef) #:transparent) -(struct cons-expr (e1 e2) #:transparent) -(struct car-expr (e) #:transparent) -(struct cdr-expr (e) #:transparent) -(struct null-expr () #:transparent) -(struct null?-expr (e) #:transparent) -(struct app (f e) #:transparent) ; <------------------ !!! -(struct lam (id e) #:transparent) ; <------------------ !!! - -(define (expr? e) - (match e - [(const n) (or (number? n) (boolean? n))] - [(binop op l r) (and (symbol? op) (expr? l) (expr? r))] - [(var-expr x) (symbol? x)] - [(let-expr x e1 e2) - (and (symbol? x) (expr? e1) (expr? e2))] - [(if-expr eb et ef) - (and (expr? eb) (expr? et) (expr? ef))] - [(cons-expr e1 e2) (and (expr? e1) (expr? e2))] - [(car-expr e) (expr? e)] - [(cdr-expr e) (expr? e)] - [(null-expr) true] - [(null?-expr e) (expr? e)] - [(app f e) (and (expr? f) (expr? e))] ; <--------------------- !!! - [(lam id e) (and (symbol? id) (expr? e))] ; <----------------- !!! - [_ false])) - -(define (parse q) - (cond - [(number? q) (const q)] - [(eq? q 'true) (const true)] - [(eq? q 'false) (const false)] - [(eq? q 'null) (null-expr)] - [(symbol? q) (var-expr q)] - [(and (list? q) (eq? (length q) 2) (eq? (first q) 'null?)) - (null?-expr (parse (second q)))] - [(and (list? q) (eq? (length q) 3) (eq? (first q) 'cons)) - (cons-expr (parse (second q)) - (parse (third q)))] - [(and (list? q) (eq? (length q) 2) (eq? (first q) 'car)) - (car-expr (parse (second q)))] - [(and (list? q) (eq? (length q) 2) (eq? (first q) 'cdr)) - (cdr-expr (parse (second q)))] - [(and (list? q) (eq? (length q) 3) (eq? (first q) 'let)) - (let-expr (first (second q)) - (parse (second (second q))) - (parse (third q)))] - [(and (list? q) (eq? (length q) 4) (eq? (first q) 'if)) - (if-expr (parse (second q)) - (parse (third q)) - (parse (fourth q)))] - [(and (list? q) (eq? (length q) 3) (eq? (first q) 'lambda)) ; proc (car q)))) ; <------- !!! - (parse-app q)] - [(and (list? q) (eq? (length q) 3) (symbol? (first q))) - (binop (first q) - (parse (second q)) - (parse (third q)))])) - -(define (parse-app q) ; <----------------------------------------- !!! - (define (parse-app-accum q acc) - (cond [(= 1 (length q)) (app acc (parse (car q)))] - [else (parse-app-accum (cdr q) (app acc (parse (car q))))])) - (parse-app-accum (cdr q) (parse (car q)))) - -(define (parse-lam pat e) ; <------------------------------------- !!! - (cond [(= 1 (length pat)) - (lam (car pat) (parse e))] - [else - (lam (car pat) (parse-lam (cdr pat) e))])) - -; ---------- ; -; Srodowiska ; -; ---------- ; - -(struct environ (xs) #:transparent) - -(define env-empty (environ null)) -(define (env-add x v env) - (environ (cons (cons x v) (environ-xs env)))) -(define (env-lookup x env) - (define (assoc-lookup xs) - (cond [(null? xs) (error "Unknown identifier" x)] - [(eq? x (car (car xs))) (cdr (car xs))] - [else (assoc-lookup (cdr xs))])) - (assoc-lookup (environ-xs env))) - -; --------- ; -; Ewaluacja ; -; --------- ; - -(struct clo (id e env) #:transparent) ; <------------------------- !!! -(struct odr (e env) #:transparent) - -(define (value? v) - (or (number? v) - (boolean? v) - (and (pair? v) (value? (car v)) (value? (cdr v))) - (null? v) - (clo? v))) ; <---------------------------------------------- !!! - -(define (op->proc op) - (match op ['+ +] ['- -] ['* *] ['/ /] ['% modulo] - ['= =] ['> >] ['>= >=] ['< <] ['<= <=] - ['and (lambda (x y) (and x y))] - ['or (lambda (x y) (or x y))] - [_ false])) ; <--------------------------------------- !!! - -(define (eval-env e env) - (match e - [(const n) n] - [(binop op l r) ((op->proc op) (eval-env l env) - (eval-env r env))] - [(let-expr x e1 e2) - (eval-env e2 (env-add x (eval-env e1 env) env))] - [(var-expr x) (match (env-lookup x env) - [(odr e env) (eval-env e env)] - [f f])] - [(if-expr eb et ef) (if (eval-env eb env) - (eval-env et env) - (eval-env ef env))] - [(cons-expr e1 e2) (cons (odr e1 env) - (odr e2 env))] - [(car-expr e) (let ([p (eval-env e env)]) - (match (car p) - [(odr e env) (eval-env e env)]))] - [(cdr-expr e) (let ([p (eval-env e env)]) - (match (cdr p) - [(odr e env) (eval-env e env)]))] - [(null-expr) null] - [(null?-expr e) (null? (eval-env e env))] - [(lam x e) (clo x e env)] ; <--------------------------------- !!! - [(app f e) ; <------------------------------------------------ !!! - (let ([vf (eval-env f env)] - [ve (odr e env)]) - (match vf [(clo x body fun-env) - (eval-env body (env-add x ve fun-env))]))])) - -(define (eval e) (eval-env e env-empty)) - -(define program - '(let [twice (lambda (f x) (f (f x)))] - (let [inc (lambda (x) (+ 1 x))] - (twice twice twice twice inc 1)))) - - -;;; Testy wspólnie z Karolem Ochmanem - -(define (test-eval program) (eval (parse program))) - -(define program1 - '((lambda (x) (+ 3 3)) (/ 5 0))) -(define program2 - '(let [if-fun (lambda (b t e) (if b t e))] - (if-fun true 4 (/ 5 0)))) -(define program3 - '(car (cdr (cons 1 (cons 2 (cons 3 (cons 4 null))))))) -(define program4 - '(car (cons (+ 3 4) (/ 5 0)))) -(define program5 - '(cons (+ 5 6) (- 4 3))) -(define program6 - '(car (cdr (cdr (car (cons (cons (/ 0 0) (cons (/ 0 0) (cons 1 (/ 0 0)))) (cdr (cons (/ 0 0) null)))))))) -;;; (test-eval program) -;;; (test-eval program1) -;;; (test-eval program2) -;;; (test-eval program3) -;;; (test-eval program4) -;;; (test-eval program5) -;;; (test-eval program6) \ No newline at end of file -- cgit v1.2.3