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 deletions(-)
 delete mode 100644 Semestr 2/racket/l9/zad4.rkt
 delete 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
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
-- 
cgit v1.2.3