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

(limited to 'semestr-2/racket/l13/zad6.rkt')

diff --git a/semestr-2/racket/l13/zad6.rkt b/semestr-2/racket/l13/zad6.rkt
new file mode 100644
index 0000000..1dcfbfc
--- /dev/null
+++ b/semestr-2/racket/l13/zad6.rkt
@@ -0,0 +1,132 @@
+#lang typed/racket
+
+; Do let-env.rkt dodajemy wartosci boolowskie
+;
+; Miejsca, ktore sie zmienily oznaczone sa przez !!!
+
+; --------- ;
+; Wyrazenia ;
+; --------- ;
+
+(define-type Expr (U const binop var-expr let-expr if-expr))
+(define-type Value (U Real Boolean))
+(define-type BinopSym (U '+ '- '/ '* '% '= '> '>= '< '<= 'and 'or))
+
+(struct const    ([val : Value])                          #:transparent)
+(struct binop    ([op : BinopSym] [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 expr? Expr)
+(define-predicate value? Value)
+(define-predicate binop-sym? BinopSym)
+(define-predicate let-list? (List Symbol Any))
+
+(: parse (-> Any Expr))
+(define (parse q)
+  (match q
+    [_ #:when (value? q) (const  q)]
+    [_ #:when (eq? q 'true) (const true)] 
+    [_ #:when (eq? q 'false) (const false)] ; <---------------------------- !!!
+    [_ #:when (symbol? q) (var-expr q)]
+    [`(,s ,e1 ,e2)
+      #:when (and (eq? s 'let) (let-list? e1))
+      (let-expr (car e1)
+                (parse (cadr e1))
+                (parse e2))]
+    [`(,s ,eb ,et ,ef)
+      #:when (eq? s 'if)
+     (if-expr (parse eb)
+              (parse et)
+              (parse ef))]
+    [`(,s ,e1 ,e2)
+      #:when (binop-sym? s)
+     (binop s
+            (parse e1)
+            (parse e2))]
+    [else (error "Parse error" q)]))
+
+;;; (define (test-parse) (parse '(let [x (+ 2 2)] (+ x 1))))
+
+; ---------- ;
+; Srodowiska ;
+; ---------- ;
+
+(struct environ ([xs : (Listof (Pairof Symbol Value))]))
+(define env-empty (environ null))
+
+(: env-add (-> Symbol Value environ environ))
+(define (env-add x v env)
+  (environ (cons (cons x v) (environ-xs env))))
+
+(: env-lookup (-> Symbol environ Value))
+(define (env-lookup x env) 
+  (: assoc-lookup (-> (Listof (Pairof Symbol Value)) Value))
+  (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)))
+
+; --------- ;
+; Ewaluacja ;
+; --------- ;
+
+(: arith-op (-> (-> Real Real Real) (-> Value Value Value)))
+(define (arith-op op)
+  (lambda (x y) (if (and (real? x) (real? y))
+                    (ann (op x y) Value)
+                    (error "Wrong args for arithmetic operator" op x y))))
+
+(: mod-op (-> (-> Integer Integer Integer) (-> Value Value Value)))
+(define (mod-op op)
+  (lambda (x y) (if (and (exact-integer? x) (exact-integer? y))
+                    (ann (op x y) Value)
+                    (error "Wrong args for modulo operator" op x y))))
+
+(: logic-op (-> (-> Boolean Boolean Boolean) (-> Value Value Value)))
+(define (logic-op op)
+  (lambda (x y) (if (and (boolean? x) (boolean? y))
+                    (ann (op x y) Value)
+                    (error "Wrong args for logic operator" op x y))))
+
+(: comp-op (-> (-> Real Real Boolean) (-> Value Value Value)))
+(define (comp-op op)
+  (lambda (x y) (if (and (real? x) (real? y))
+                    (ann (op x y) Value)
+                    (error "Wrong args for comparator" op x y))))
+
+
+(: op->proc (-> BinopSym (-> Value Value Value)))
+(define (op->proc op)
+  (match op ['+ (arith-op +)] ['- (arith-op -)] ['* (arith-op *)] ['/ (arith-op /)] 
+            ['% (mod-op modulo)]
+            ['= (comp-op =)] ['> (comp-op >)] ['>= (comp-op >=)] ['< (comp-op <)] ['<= (comp-op <=)]
+            ['and (logic-op (lambda (x y) (and x y)))]
+            ['or  (logic-op (lambda (x y) (or  x y)))]))
+
+(: eval-env (-> Expr environ Value))
+(define (eval-env e env)
+  (match e
+    [(const n) n]
+    [(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))]
+    [(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))]))
+
+(: eval (-> Expr Value))
+(define (eval e) (eval-env e env-empty))
+
+(define program
+  '(if (or (< (% 123 10) 5)
+           true)
+       (+ 2 3)
+       (/ 2 0)))
+
+;;; (define (test-eval) (eval (parse program)))
\ No newline at end of file
-- 
cgit v1.2.3