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/l7z13/solution.rkt | 104 ++++++++++++++++++++++++++++++++++++
 1 file changed, 104 insertions(+)
 create mode 100644 semestr-2/racket/l7z13/solution.rkt

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

diff --git a/semestr-2/racket/l7z13/solution.rkt b/semestr-2/racket/l7z13/solution.rkt
new file mode 100644
index 0000000..0a0278a
--- /dev/null
+++ b/semestr-2/racket/l7z13/solution.rkt
@@ -0,0 +1,104 @@
+#lang racket
+
+(provide (struct-out const) (struct-out binop) (struct-out var-expr) (struct-out let-expr) (struct-out var-dead) find-dead-vars)
+
+
+; --------- ;
+; Wyrazenia ;
+; --------- ;
+
+(struct const    (val)      #:transparent)
+(struct binop    (op l r)   #:transparent)
+(struct var-expr (id)       #:transparent)
+(struct var-dead (id)       #:transparent)
+(struct let-expr (id e1 e2) #:transparent)
+
+(define (expr? e)
+  (match e
+    [(const n) (number? n)]
+    [(binop op l r) (and (symbol? op) (expr? l) (expr? r))]
+    [(var-expr x) (symbol? x)]
+    [(var-dead x) (symbol? x)]
+    [(let-expr x e1 e2) (and (symbol? x) (expr? e1) (expr? e2))]
+    [_ false]))
+
+(define (parse q)
+  (cond
+    [(number? q) (const q)]
+    [(symbol? q) (var-expr 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) (symbol? (first q)))
+     (binop (first q)
+            (parse (second q))
+            (parse (third q)))]))
+
+; ---------------------------------- ;
+; Wyszukaj ostatnie uzycie zmiennych ;
+; ---------------------------------- ;
+
+(struct environ (xs))
+
+(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 "unbound identifier" x)]
+          [(eq? x (car (car xs))) (cdr (car xs))]
+          [else (assoc-lookup (cdr xs))]))
+  (assoc-lookup (environ-xs env)))
+(define (env-erase x env)
+  (define (assoc-lookup xs)
+    (cond [(null? xs) (error "unbound identifier" x)]
+          [(eq? x (caar xs)) (cdr xs)]
+          [else (cons (car xs) (assoc-lookup (cdr xs)))]))
+  (if (env-lookup x env)
+      (environ (assoc-lookup (assoc-lookup (environ-xs env))))
+      (environ (assoc-lookup (environ-xs env)))))
+
+
+(define (find-dead-vars-env e env)
+  (match e
+    [(const r) (cons (const r) env)]
+    [(var-expr x) (if (env-lookup x env)
+                     (cons (var-expr x) env)
+                     (cons (var-dead x) (env-add x true env)))]
+    [(binop op l r) (let* ((right-expr (find-dead-vars-env r env))
+                           (r (car right-expr))
+                           (env (cdr right-expr))
+                           (left-expr (find-dead-vars-env l env))
+                           (l (car left-expr))
+                           (env (cdr left-expr)))
+                        (cons (binop op l r) env))]
+    [(let-expr x e1 e2) (let* ((right-expr (find-dead-vars-env e2 (env-add x false env)))
+                               (e2 (car right-expr))
+                               (env (env-erase x (cdr right-expr)))
+                               (left-expr (find-dead-vars-env e1 env))
+                               (e1 (car left-expr))
+                               (env (cdr left-expr)))
+                            (cons (let-expr x e1 e2) env))]))
+
+(define (find-dead-vars e)
+  (car (find-dead-vars-env e env-empty)))
+
+
+(define (sample2) (find-dead-vars (let-expr 'x (const 3)
+                                      (binop '+ (var-expr 'x)
+                                      (let-expr 'x (const 5) (binop '+ (var-expr 'x) (var-expr 'x)))))))
+
+(define (test1) (find-dead-vars (parse '(let (x 3) (let (x (* x (+ x x))) (+ x x))))))
+(define (test2) (find-dead-vars (parse '(let (x 2) (let [x (let [x (+ x 2)] x)] x)))))
+(define (test3) (find-dead-vars (parse '(let [x 2] (+ (let [x (+ 2 x)] (* 3 x)) x)))))
+(define (test4) (find-dead-vars (parse '(let [x 2] (let [x (+ x 3)] (* x x))))))
+(define (test5) (find-dead-vars (parse '(let [x 2] (+ x (let [x (+ 2 x)] x))))))
+(define (test6) (find-dead-vars (parse '(let [x 2] 
+                                             (let [y (let [x (* x (+ x x))] 
+                                                          (let [y (* x x)] 
+                                                               (+ y 2)))] 
+                                             (+ x (* y y)))))))
+(define (test7) (find-dead-vars (parse '(let [x (let [x (let [x 2] (+ x x))] (+ x x))] (+ x x)))))
+;;; (define (test7) (find-dead-vars (parse '(let [x (let [x (let [x 2] (let (x 2) (+ x x)))] (+ x x))] (+ x x)))))
+(define (test8) (find-dead-vars (parse '(let [x 2] (let [x 2] (+ x x))))))
\ No newline at end of file
-- 
cgit v1.2.3