From c5fcf7179a83ef65c86c6a4a390029149e518649 Mon Sep 17 00:00:00 2001
From: Franciszek Malinka <franciszek.malinka@gmail.com>
Date: Tue, 5 Oct 2021 21:49:54 +0200
Subject: Duzy commit ze smieciami

---
 semestr-2/racket/l9/zad4.rkt | 202 +++++++++++++++++++++++++
 semestr-2/racket/l9/zad7.rkt | 340 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 542 insertions(+)
 create mode 100644 semestr-2/racket/l9/zad4.rkt
 create mode 100644 semestr-2/racket/l9/zad7.rkt

(limited to 'semestr-2/racket/l9')

diff --git a/semestr-2/racket/l9/zad4.rkt b/semestr-2/racket/l9/zad4.rkt
new file mode 100644
index 0000000..7b5e0bc
--- /dev/null
+++ b/semestr-2/racket/l9/zad4.rkt
@@ -0,0 +1,202 @@
+#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
new file mode 100644
index 0000000..207162d
--- /dev/null
+++ b/semestr-2/racket/l9/zad7.rkt
@@ -0,0 +1,340 @@
+#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
-- 
cgit v1.2.3