diff options
Diffstat (limited to 'Semestr 2/racket/l9')
| -rw-r--r-- | Semestr 2/racket/l9/zad4.rkt | 202 | ||||
| -rw-r--r-- | Semestr 2/racket/l9/zad7.rkt | 340 |
2 files changed, 0 insertions, 542 deletions
diff --git a/Semestr 2/racket/l9/zad4.rkt b/Semestr 2/racket/l9/zad4.rkt deleted file mode 100644 index 7b5e0bc..0000000 --- a/Semestr 2/racket/l9/zad4.rkt +++ /dev/null @@ -1,202 +0,0 @@ -#lang racket
-
-; Do fun.rkt dodajemy rekurencyjne let-y
-;
-; Miejsca, ktore sie zmienily oznaczone sa przez !!!
-
-; --------- ;
-; Wyrazenia ;
-; --------- ;
-
-(struct const (val) #:transparent)
-(struct binop (op l r) #:transparent)
-(struct var-expr (id) #:transparent)
-(struct let-expr (id e1 e2) #:transparent)
-(struct letrec-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)
-(struct citation (q) #: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))]
- [(letrec-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))]
- [(citation q) true]
- [_ 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? 'quote (first q))) (citation (second 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) 3) (eq? (first q) 'letrec)) ; <!!!
- (letrec-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))
- (parse-lam (second q) (third q))]
- [(and (list? q) (pair? q) (not (op->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 blackhole () #:transparent) ; <------------------------- !!!
-(struct environ (xs) #:transparent)
-
-(define env-empty (environ null))
-(define (env-add x v env)
- (environ (cons (mcons x v) (environ-xs env)))) ; <-------------- !!!
-(define (env-lookup x env)
- (define (assoc-lookup xs)
- (cond [(null? xs) (error "Unknown identifier" x)]
- [(eq? x (mcar (car xs))) ; <---------------------------- !!!
- (match (mcdr (car xs))
- [(blackhole) (error "Stuck forever in a black hole!")]
- [x x])]
- [else (assoc-lookup (cdr xs))]))
- (assoc-lookup (environ-xs env)))
-(define (env-update! x v xs) ; <---------------------------------- !!!
- (define (assoc-update! xs)
- (cond [(null? xs) (error "Unknown identifier" x)]
- [(eq? x (mcar (car xs))) (set-mcdr! (car xs) v)]
- [else (env-update! x v (cdr xs))]))
- (assoc-update! (environ-xs xs)))
-
-; --------- ;
-; Ewaluacja ;
-; --------- ;
-
-(struct clo (id e env) #:transparent)
-
-(define (value? v)
- (or (number? v)
- (boolean? v)
- (and (pair? v) (value? (car v)) (value? (cdr v)))
- (null? v)
- (clo? v)
- (blackhole? 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]
- [(citation q) q]
- [(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))]
- [(letrec-expr x e1 e2) ; <------------------------------------ !!!
- (let* ([new-env (env-add x (blackhole) env)]
- [v (eval-env e1 new-env)])
- (begin
- (env-update! x v new-env)
- (eval-env e2 new-env)))]
- [(var-expr x) (env-lookup x env)]
- [(if-expr eb et ef) (if (eval-env eb env)
- (eval-env et env)
- (eval-env ef env))]
- [(cons-expr e1 e2) (cons (eval-env e1 env)
- (eval-env e2 env))]
- [(car-expr e) (car (eval-env e env))]
- [(cdr-expr e) (cdr (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 (eval-env 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
- '(letrec
- [fact (lambda (n) (if (= n 0) 1 (* n (fact (- n 1)))))]
- (letrec
- [even-odd
- (cons
- (lambda (x)
- (if (= x 0) true ((cdr even-odd) (- x 1))))
- (lambda (x)
- (if (= x 0) false ((car even-odd) (- x 1)))))]
- (let [even (car even-odd)]
- (let [odd (cdr even-odd)]
- (even (fact 6)))))))
-
-(define PROGRAM
- '(letrec [from-to (lambda (n k)
- (if (> n k)
- null
- (cons n (from-to (+ n 1) k))))]
- (letrec [sum (lambda (xs)
- (if (null? xs)
- 0
- (+ (car xs) (sum (cdr xs)))))]
- (sum (from-to 1 36)))))
-
-(define (test-eval) (eval (parse PROGRAM)))
\ No newline at end of file diff --git a/Semestr 2/racket/l9/zad7.rkt b/Semestr 2/racket/l9/zad7.rkt deleted file mode 100644 index 207162d..0000000 --- a/Semestr 2/racket/l9/zad7.rkt +++ /dev/null @@ -1,340 +0,0 @@ -#lang racket
-
-;; Składnia abstrakcyjna
-(struct const (val) #:transparent)
-(struct var-expr (name) #:transparent)
-(struct let-expr (id bound body) #:transparent)
-(struct letrec-expr (id bound body) #:transparent)
-(struct if-expr (eb et ef) #:transparent)
-(struct lambda-expr (arg body) #:transparent)
-(struct app-expr (fun arg) #:transparent)
-(struct display-expr (e) )
-
-(define (keyword s)
- (member s '(true false null and or if cond else lambda let letrec display read)))
-
-(define (expr? e)
- (match e
- [(const n) (or (number? n)
- (boolean? n)
- (null? n)
- (string? n))]
- [(var-expr id) (symbol? id)]
- [(let-expr x e1 e2 ) (and (symbol? x)
- (expr? e1)
- (expr? e2))]
- [(letrec-expr x e1 e2) (and (symbol? x)
- (expr? e1)
- (expr? e2))]
- [(if-expr eb et ef) (and (expr? eb)
- (expr? et)
- (expr? ef))]
- [(lambda-expr x e) (and (symbol? x)
- (expr? e))]
- [(app-expr ef ea) (and (expr? ef)
- (expr? ea))]
- [_ false]))
-
-;; Parsowanie (zacytowane wyrażenie -> składnia abstrakcyjna)
-(define (parse q)
- (cond
- [(number? q) (const q)]
- [(string? q) (const q)]
- [(eq? q 'true) (const true)]
- [(eq? q 'false) (const false)]
- [(eq? q 'null) (const null)]
- [(and (symbol? q)
- (not (keyword q)))
- (var-expr q)]
- [(and (list? q)
- (= (length q) 3)
- (eq? (first q) 'let)
- (list? (second q))
- (= (length (second q)) 2)
- (symbol? (first (second q))))
- (let-expr (first (second q))
- (parse (second (second q)))
- (parse (third q)))]
- [(and (list? q)
- (= (length q) 3)
- (eq? (first q) 'letrec)
- (list? (second q))
- (= (length (second q)) 2)
- (symbol? (first (second q))))
- (letrec-expr (first (second q))
- (parse (second (second q)))
- (parse (third q)))]
- [(and (list? q)
- (= (length q) 4)
- (eq? (first q) 'if))
- (if-expr (parse (second q))
- (parse (third q))
- (parse (fourth q)))]
- [(and (list? q)
- (pair? q)
- (eq? (first q) 'and))
- (desugar-and (map parse (cdr q)))]
- [(and (list? q)
- (pair? q)
- (eq? (first q) 'or))
- (desugar-or (map parse (cdr q)))]
- [(and (list? q)
- (>= (length q) 2)
- (eq? (first q) 'cond))
- (parse-cond (cdr q))]
- [(and (list? q)
- (= (length q) 3)
- (eq? (first q) 'lambda)
- (list? (second q))
- (andmap symbol? (second q))
- (cons? (second q)))
- (desugar-lambda (second q) (parse (third q)))]
- [(and (list? q)
- (>= (length q) 2))
- (desugar-app (parse (first q)) (map parse (cdr q)))]
- [else (error "Unrecognized token:" q)]))
-
-(define (parse-cond qs)
- (match qs
- [(list (list 'else q))
- (parse q)]
-
- [(list (list q _))
- (error "Expected 'else' in last branch but found:" q)]
-
- [(cons (list qb qt) qs)
- (if-expr (parse qb) (parse qt) (parse-cond qs))]))
-
-(define (desugar-and es)
- (if (null? es)
- (const true)
- (if-expr (car es) (desugar-and (cdr es)) (const false))))
-
-(define (desugar-or es)
- (if (null? es)
- (const false)
- (if-expr (car es) (const true) (desugar-or (cdr es)))))
-
-(define (desugar-lambda xs e)
- (if (null? xs)
- e
- (lambda-expr (car xs) (desugar-lambda (cdr xs) e))))
-
-(define (desugar-app e es)
- (if (null? es)
- e
- (desugar-app (app-expr e (car es)) (cdr es))))
-
-;; Środowiska
-(struct blackhole ())
-(struct environ (xs))
-
-(define env-empty (environ null))
-(define (env-add x v env)
- (environ (cons (mcons x v) (environ-xs env))))
-(define (env-lookup x env)
- (define (assoc-lookup xs)
- (cond [(null? xs)
- (error "Unknown identifier" x)]
- [(eq? x (mcar (car xs)))
- (let ((v (mcdr (car xs))))
- (if (blackhole? v)
- (error "Jumped into blackhole at" x)
- v))]
- [else (assoc-lookup (cdr xs))]))
- (assoc-lookup (environ-xs env)))
-(define (env-update! x v env)
- (define (assoc-update xs)
- (cond [(null? xs) (error "Unknown identifier" x)]
- [(eq? x (mcar (car xs)))
- (set-mcdr! (car xs) v)]
- [else (assoc-update (cdr xs))]))
- (assoc-update (environ-xs env)))
-
-;; Domknięcia
-(struct clo (arg body env))
-
-;; Procedury wbudowane, gdzie
-;; proc — Racketowa procedura którą należy uruchomić
-;; args — lista dotychczas dostarczonych argumentów
-;; pnum — liczba brakujących argumentów (> 0)
-;; W ten sposób pozwalamy na częściową aplikację Racketowych procedur
-;; — zauważmy że zawsze znamy pnum, bo w naszym języku arność
-;; procedury jest ustalona z góry
-(struct builtin (proc args pnum))
-
-;; Pomocnicze konstruktory procedur unarnych i binarnych
-(define (builtin/1 p)
- (builtin p null 1))
-(define (builtin/2 p)
- (builtin p null 2))
-
-;; Procedury
-(define (proc? v)
- (or (and (clo? v)
- (symbol? (clo-arg v))
- (expr? (clo-body v))
- (environ? (clo-env v)))
- (and (builtin? v)
- (procedure? (builtin-proc v))
- (andmap value? (builtin-args v))
- (natural? (builtin-pnum v))
- (> (builtin-pnum v) 0))))
-
-;; Definicja typu wartości
-(define (value? v)
- (or (number? v)
- (boolean? v)
- (null? v)
- (string? v)
- (and (cons? v)
- (value? (car v))
- (value? (cdr v)))
- (proc? v)))
-
-;; Środowisko początkowe (przypisujące procedury wbudowane ich nazwom)
-
-(define start-env
- (foldl (lambda (p env) (env-add (first p) (second p) env))
- env-empty
- `((+ ,(builtin/2 +))
- (- ,(builtin/2 -))
- (* ,(builtin/2 *))
- (/ ,(builtin/2 /))
- (~ ,(builtin/1 -))
- (< ,(builtin/2 <))
- (> ,(builtin/2 >))
- (= ,(builtin/2 =))
- (<= ,(builtin/2 <=))
- (>= ,(builtin/2 >=))
- (not ,(builtin/1 not))
- (cons ,(builtin/2 cons))
- (car ,(builtin/1 car))
- (cdr ,(builtin/1 cdr))
- (pair? ,(builtin/1 cons?))
- (null? ,(builtin/1 null?))
- (boolean? ,(builtin/1 boolean?))
- (number? ,(builtin/1 number?))
- (procedure? ,(builtin/1 (lambda (x) (or (clo? x) (builtin? x)))))
- (string? ,(builtin/1 string?))
- (string-= ,(builtin/2 string=?))
- ;; and so on, and so on
- )))
-
-;; Ewaluator
-(define (eval-env e env)
- (match e
- [(const n)
- n]
-
- [(var-expr x)
- (env-lookup x env)]
-
- [(let-expr x e1 e2)
- (let ((v1 (eval-env e1 env)))
- (eval-env e2 (env-add x v1 env)))]
-
- [(letrec-expr f ef eb)
- (let* ((new-env (env-add f (blackhole) env))
- (vf (eval-env ef new-env)))
- (env-update! f vf new-env)
- (eval-env eb new-env))]
-
- [(if-expr eb et ef)
- (match (eval-env eb env)
- [#t (eval-env et env)]
- [#f (eval-env ef env)]
- [v (error "Not a boolean:" v)])]
-
- [(lambda-expr x e)
- (clo x e env)]
-
- [(app-expr ef ea)
- (let ((vf (eval-env ef env))
- (va (eval-env ea env)))
- (match vf
- [(clo x e env)
- (eval-env e (env-add x va env))]
- [(builtin p args nm)
- (if (= nm 1)
- (apply p (reverse (cons va args)))
- (builtin p (cons va args) (- nm 1)))]
- [_ (error "Not a function:" vf)]))]))
-
-(define (eval e)
- (eval-env e start-env))
-
-
-;; REPL — interpreter interaktywny (read-eval-print loop)
-
-;; dodajemy składnię na wiązanie zmiennych "na poziomie interpretera"
-;; i komendę wyjścia "exit" ...
-(struct letrec-repl (id expr))
-(struct let-repl (id expr))
-(struct exit-repl ())
-
-;; ... a także rozszerzoną procedurę parsującą te dodatkowe komendy i
-;; prostą obsługę błędów
-(define (parse-repl q)
- (with-handlers
- ([exn? (lambda (exn)
- (display "Parse error! ")
- (displayln (exn-message exn)))])
- (cond
- [(eq? q 'exit) (exit-repl)]
- [(and (list? q)
- (= 3 (length q))
- (eq? (first q) 'let))
- (let-repl (second q) (parse (third q)))]
- [(and (list? q)
- (= 3 (length q))
- (eq? (first q) 'letrec))
- (letrec-repl (second q) (parse (third q)))]
- [else (parse q)])))
-
-;; trochę zamieszania w procedurze eval-repl wynika z rudymentarnej
-;; obsługi błędów: nie chcemy żeby błąd w interpretowanym programie
-;; kończył działanie całego interpretera!
-(define (eval-repl c env continue)
- (define (eval-with-err e env)
- (with-handlers
- ([exn? (lambda (exn)
- (display "Error! ")
- (displayln (exn-message exn)))])
- (eval-env e env)))
- (match c
- [(exit-repl)
- (void)]
-
- [(let-repl x e)
- (let ((v (eval-with-err e env)))
- (if (void? v)
- (continue env)
- (continue (env-add x v env))))]
-
- [(letrec-repl f e)
- (let* ((new-env (env-add f (blackhole) env))
- (v (eval-with-err e new-env)))
- (if (void? v)
- (continue env)
- (begin
- (env-update! f v new-env)
- (continue new-env))))]
-
- [_
- (let ((v (eval-with-err c env)))
- (unless (void? v)
- (displayln v))
- (continue env))]))
-
-;; I w końcu interaktywny interpreter
-(define (repl)
- (define (go env)
- (display "FUN > ")
- (let* ((q (read))
- (c (parse-repl q)))
- (if (void? c)
- (go env)
- (eval-repl c env go))))
- (displayln "Welcome to the FUN functional language interpreter!")
- (go start-env))
\ No newline at end of file |