diff options
Diffstat (limited to 'semestr-2/racket/l10z18')
-rw-r--r-- | semestr-2/racket/l10z18/solution.bak | 363 | ||||
-rw-r--r-- | semestr-2/racket/l10z18/solution.rkt | 409 |
2 files changed, 772 insertions, 0 deletions
diff --git a/semestr-2/racket/l10z18/solution.bak b/semestr-2/racket/l10z18/solution.bak new file mode 100644 index 0000000..02eb770 --- /dev/null +++ b/semestr-2/racket/l10z18/solution.bak @@ -0,0 +1,363 @@ +#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) + +(define (keyword s) + (member s '(true false null and or if cond else lambda let letrec))) + +(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) #:transparent) + +;; Pomocnicze konstruktory procedur unarnych i binarnych +(define (builtin/1 p) + (builtin (lambda (x) (return (p x))) null 1)) +(define (builtin/2 p) + (builtin (lambda (x y) (return (p x y))) 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 + ))) + +;; Efekt + +(define (effect-builtin/1 p) + (builtin p null 1)) +(define (effect-builtin/2 p) + (builtin p null 2)) + +(define effect-env + (foldl (lambda (p env) (env-add (first p) (second p) env)) + start-env + `((choose ,(effect-builtin/2 (lambda (x y) (list x y)))) + ))) + +(define (bind c k) (append-map k c)) + +(define (return x) (list x)) + +;; Ewaluator +(define (eval-env e env) + (match e + [(const n) + (return n)] + + [(var-expr x) + (return (env-lookup x env))] + + [(let-expr x e1 e2) + (bind (eval-env e1 env) (lambda (v1) + (eval-env e2 (env-add x v1 env))))] + + [(letrec-expr f ef eb) + (let ((new-env (env-add f (blackhole) env))) + (bind (eval-env ef new-env) (lambda (vf) + (env-update! f vf new-env) + (eval-env eb new-env))))] + + [(if-expr eb et ef) + (bind (eval-env eb env) (lambda (vb) + (match vb + [#t (eval-env et env)] + [#f (eval-env ef env)] + [v (error "Not a boolean:" v)])))] + + [(lambda-expr x e) + (return (clo x e env))] + + [(app-expr ef ea) + (bind (eval-env ef env) (lambda (vf) + (bind (eval-env ea env) (lambda (va) + (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))) + (return (builtin p (cons va args) (- nm 1))))] + [_ (error "Not a function:" vf)])))))])) + +(define (eval e) + (eval-env e effect-env)) + + +;; Przykladowy program + +(define PROGRAM + '((if (choose true false) (lambda (x) x) (lambda (x) (+ x 1))) (choose 1 2))) + + +;; 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 diff --git a/semestr-2/racket/l10z18/solution.rkt b/semestr-2/racket/l10z18/solution.rkt new file mode 100644 index 0000000..7adcea4 --- /dev/null +++ b/semestr-2/racket/l10z18/solution.rkt @@ -0,0 +1,409 @@ +#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) + +(provide parse eval norm) + +(define (keyword s) + (member s '(true false null and or if cond else lambda let letrec))) + +(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) #:transparent) + +;; Pomocnicze konstruktory procedur unarnych i binarnych +(define (builtin/1 p) + (builtin (lambda (x) (return (p x))) null 1)) +(define (builtin/2 p) + (builtin (lambda (x y) (return (p x y))) 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 + ))) + +;; Efekt + +(define (effect-builtin/1 p) + (builtin p null 1)) +(define (effect-builtin/2 p) + (builtin p null 2)) +(define (effect-builtin/3 p) + (builtin p null 3)) + + +(define effect-env + (foldl (lambda (p env) (env-add (first p) (second p) env)) + start-env + `((flip ,(effect-builtin/3 (lambda (p x y) (list (cons p x) (cons (- 1 p) y))))) + (uniform ,(effect-builtin/1 (lambda (x) (let ((l (/ 1 (length x)))) + (map (lambda (x) (cons l x)) x))))) + ))) + +;; c to lista par (pstwo, wartość) +;; k to funkcja która przyjmuje wartość i coś z nią robi sobie i zwraca listę par (pstwo, wartość) + +(define (bind c k) + (append-map + (lambda (x) (let ((pstwo (car x)) + (val (cdr x))) + (map + (lambda (x) (cons (* pstwo (car x)) (cdr x))) + (k (cdr x))))) + c)) + +(define (return x) (list (cons 1 x))) + +;; Ewaluator +(define (eval-env e env) + (match e + [(const n) + (return n)] + + [(var-expr x) + (return (env-lookup x env))] + + [(let-expr x e1 e2) + (bind (eval-env e1 env) (lambda (v1) + (eval-env e2 (env-add x v1 env))))] + + [(letrec-expr f ef eb) + (let ((new-env (env-add f (blackhole) env))) + (bind (eval-env ef new-env) (lambda (vf) + (env-update! f vf new-env) + (eval-env eb new-env))))] + + [(if-expr eb et ef) + (bind (eval-env eb env) (lambda (vb) + (match vb + [#t (eval-env et env)] + [#f (eval-env ef env)] + [v (error "Not a boolean:" v)])))] + + [(lambda-expr x e) + (return (clo x e env))] + + [(app-expr ef ea) + (bind (eval-env ef env) (lambda (vf) + (bind (eval-env ea env) (lambda (va) + (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))) + (return (builtin p (cons va args) (- nm 1))))] + [_ (error "Not a function:" vf)])))))])) + +(define (eval e) + (eval-env e effect-env)) + + +;; Przykladowy program + +(define PROGRAM + '((if (choose true false) (lambda (x) x) (lambda (x) (+ x 1))) (choose 1 2))) + + +;; 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)) + + +(define prog '(if (flip 0.3 true false) "wygrana" "przegrana")) + + +(define (norm xs) + (define sum (lambda (xs) (foldl + 0 xs))) + (define carlist (lambda (xs) (map car xs))) + (define (iter xs res) + (cond + [(null? xs) res] + [(member (cdar xs) (map cdr res)) (iter (cdr xs) res)] + [else (let* ((cur (cdar xs)) + (pstwa (filter (lambda (x) (equal? (cdr x) cur)) xs))) + (iter (cdr xs) (cons (cons (sum (carlist pstwa)) cur) res)))])) + (iter xs null)) + + +(define DICE-MANY + '(letrec [from-to (lambda (x n) + (cons x + (if (= x n) + null + (from-to (+ 1 x) n))))] + (let [dice (lambda (x) (uniform (from-to 1 6)))] + (letrec [dice-many (lambda (n) (if (= n 0) + 0 + (+ (dice 0) (dice-many (- n 1)))))] + (dice-many (dice 0))))))
\ No newline at end of file |