From 9477dbe667f250ecd23f8fc0d56b942191526421 Mon Sep 17 00:00:00 2001
From: Franciszek Malinka <franciszek.malinka@gmail.com>
Date: Thu, 25 Feb 2021 14:42:55 +0100
Subject: Stare semestry, niepoukladane

---
 Semestr 2/racket/luk.rkt | 137 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 137 insertions(+)
 create mode 100644 Semestr 2/racket/luk.rkt

(limited to 'Semestr 2/racket/luk.rkt')

diff --git a/Semestr 2/racket/luk.rkt b/Semestr 2/racket/luk.rkt
new file mode 100644
index 0000000..cc319a5
--- /dev/null
+++ b/Semestr 2/racket/luk.rkt	
@@ -0,0 +1,137 @@
+#lang typed/racket
+
+; Do let-env.rkt dodajemy wartosci boolowskie
+;
+; Miejsca, ktore sie zmienily oznaczone sa przez !!!
+
+; --------- ;
+; Wyrazenia ;
+; --------- ;
+(provide parse typecheck)
+
+(define-type Value (U Boolean Real))
+(define-type Expr (U const binop var-expr let-expr if-expr))
+(define-type ArithSymbol (U '+ '- '* '/))
+(define-type LogicSymbol (U 'and 'or))
+(define-type CompSymbol (U '< '= '> '<= '>=))
+(define-type BinomSymbol (U ArithSymbol LogicSymbol CompSymbol))
+
+(define-type Binop-list (List BinomSymbol Any Any))
+(define-type Let-list (List 'let (List Symbol Any) Any))
+(define-type If-list (List 'if Any Any Any))
+
+(define-predicate Binop-list? Binop-list)
+(define-predicate Let-list? Let-list)
+(define-predicate If-list? If-list)
+
+(struct const    ([val : Value])      #:transparent)
+(struct binop    ([op : BinomSymbol] [l : Expr] [r : Expr])   #:transparent)
+(struct var-expr ([id : Symbol])       #:transparent)
+(struct let-expr ([id : Symbol] [e1 : Expr] [e2 : Expr]) #:transparent)
+(struct if-expr  ([eb : Expr] [et : Expr] [ef : Expr]) #:transparent)
+
+(define-predicate Value? Value)
+(define-predicate Expr? Expr)
+(define-predicate BinomSymbol? BinomSymbol)
+(define-predicate ArithSymbol? ArithSymbol)
+(define-predicate LogicSymbol? LogicSymbol)
+(define-predicate CompSymbol? CompSymbol)
+(define-predicate BinomValue? BinomValue)
+
+
+
+(: parse (-> Any Expr))
+(define (parse q)
+  (cond
+    [(real? q) (const q)]
+    [(eq? q 'true)  (const true)]  ; <---------------------------- !!!
+    [(eq? q 'false) (const false)] ; <---------------------------- !!!
+    [(symbol? q) (var-expr q)]
+    [(Let-list? q)
+     (let-expr (first (second q))
+               (parse (second (second q)))
+               (parse (third q)))]
+    [(If-list? q) ; <--- !!!
+     (if-expr (parse (second q))
+              (parse (third q))
+              (parse (fourth q)))]
+    [(Binop-list? q)
+     (binop (first q)
+            (parse (second q))
+            (parse (third q)))]
+    [else (error "Blad parsowania" q)]))
+
+   
+
+
+(define (test-parse) (parse '(let [x (+ 2 2)] (+ x 1))))
+
+; ---------- ;
+; Srodowiska ;
+; ---------- ;
+(define-type EType ( U 'real 'boolean ) )
+(define-type Env (Listof (Pairof Symbol EType)))
+(define-predicate Env? Env)
+(struct environ ([xs : Env]))
+
+(: env-empty environ)
+(define env-empty (environ null))
+(: env-add (-> Symbol EType environ environ))
+(define (env-add x v env)
+  (environ (cons (cons x v) (environ-xs env))))
+(: env-lookup (-> Symbol environ (U EType #f)))
+(define (env-lookup x env)
+  (: assoc-lookup (-> Env EType))
+  (define (assoc-lookup xs)
+    (cond [(null? xs) (error "Unknown identifier" x)]
+          [(eq? x (car (car xs))) (cdr (car xs))]
+          [else (assoc-lookup (cdr xs))]))
+  (assoc-lookup (environ-xs env)))
+
+
+(: typecheck (-> Expr (U EType #f)))
+(define (typecheck q)
+  (: give (-> Expr environ (U EType #f)))
+  (define (give q envi)
+  (cond
+    [(const? q) (if (boolean? (const-val q)) 'boolean 'real)]
+    [(var-expr? q) (env-lookup (var-expr-id q) envi)]
+    [(let-expr? q)
+     (let ([p (give (let-expr-e1 q) envi)]) (if (false? p) #f (give (let-expr-e2 q) (env-add (let-expr-id q) p envi))))]
+    [(binop? q)
+     (cond
+       ([ArithSymbol? (binop-op q)] (if (and (eq? 'real (give (binop-l q) envi)) (eq? 'real (give (binop-r q) envi))) 'real #f))
+       ([LogicSymbol? (binop-op q)] (if (and (eq? 'boolean (give (binop-l q) envi)) (eq? 'boolean (give (binop-r q) envi))) 'boolean #f))
+       ([CompSymbol? (binop-op q)] (if (and (eq? 'real (give (binop-l q) envi)) (eq? 'real (give (binop-r q) envi))) 'boolean #f))
+       [else #f])]
+    [(if-expr? q)
+     (if (and (eq? 'real (if-expr-eb q)) 
+              (eq? (give (if-expr-et q) envi) (give (if-expr-ef q) envi))) 
+         (give (if-expr-et q) envi) 
+         #f)]
+    [else #f]))
+
+
+  (give q env-empty))
+
+
+
+(define program2
+  '(if true
+       (let [x 5] (+ 5 false))
+       (/ 2 2)))
+
+(define program3
+  '(let [x (+ 2 3)]
+     (let [y (< 2 3)]
+       (+ x y))))
+
+(define program4
+  '(let [x (and true true)] x))
+
+(define wtf
+  '(and true true))
+
+(typecheck (parse program2))
+(typecheck (parse program3))
+(typecheck (parse program4))
-- 
cgit v1.2.3