diff options
Diffstat (limited to 'semestr-2/racket')
87 files changed, 10740 insertions, 0 deletions
diff --git a/semestr-2/racket/cnf.rkt b/semestr-2/racket/cnf.rkt new file mode 100644 index 0000000..67bd70f --- /dev/null +++ b/semestr-2/racket/cnf.rkt @@ -0,0 +1,188 @@ +#lang racket + +(define (var? t) (symbol? t)) + +(define (neg? t) + (and (list? t) + (= 2 (length t)) + (eq? 'neg (car t)))) + +(define (conj? t) + (and (list? t) + (= 3 (length t)) + (eq? 'conj (car t)))) + +(define (disj? t) + (and (list? t) + (= 3 (length t)) + (eq? 'disj (car t)))) + +(define (lit? t) + (or (var? t) + (and (neg? t) + (var? (neg-subf t))))) + +(define (prop? f) + (or (var? f) + (and (neg? f) + (prop? (neg-subf f))) + (and (disj? f) + (prop? (disj-left f)) + (prop? (disj-right f))) + (and (conj? f) + (prop? (conj-left f)) + (prop? (conj-right f))))) + +(define (make-conj left right) + (list 'conj left right)) + +(define (make-disj left right) + (list 'disj left right)) + +(define (make-neg f) + (list 'neg f)) + +(define (conj-left f) + (if (conj? f) + (cadr f) + (error "Złe dane ze znacznikiem -- CONJ-LEFT" f))) + +(define (conj-right f) + (if (conj? f) + (caddr f) + (error "Złe dane ze znacznikiem -- CONJ-RIGHT" f))) + +(define (disj-left f) + (if (disj? f) + (cadr f) + (error "Złe dane ze znacznikiem -- DISJ-LEFT" f))) + +(define (disj-right f) + (if (disj? f) + (caddr f) + (error "Złe dane ze znacznikiem -- DISJ-RIGHT" f))) + +(define (neg-subf f) + (if (neg? f) + (cadr f) + (error "Złe dane ze znacznikiem -- NEG-FORM" f))) + +(define (lit-var f) + (cond [(var? f) f] + [(neg? f) (neg-subf f)] + [else (error "Złe dane ze znacznikiem -- LIT-VAR" f)])) + +(define (free-vars f) + (cond [(null? f) null] + [(var? f) (list f)] + [(neg? f) (free-vars (neg-subf f))] + [(conj? f) (append (free-vars (conj-left f)) + (free-vars (conj-right f)))] + [(disj? f) (append (free-vars (disj-left f)) + (free-vars (disj-right f)))] + [else (error "Zła formula -- FREE-VARS" f)])) + +(define (gen-vals xs) + (if (null? xs) + (list null) + (let* + ((vss (gen-vals (cdr xs))) + (x (car xs)) + (vst (map (λ (vs) (cons (list x true) vs)) vss)) + (vsf (map (λ (vs) (cons (list x false) vs)) vss))) + (append vst vsf)))) + +(define (eval-formula f evaluation) + (cond [(var? f) + (let ((val (assoc f evaluation))) + (if (not val) + (error "Zmienna wolna nie wystepuje w wartościowaniu -- EVAL-FORMULA" f evaluation) + (cadr val)))] + [(neg? f) (not (eval-formula (neg-subf f) evaluation))] + [(disj? f) (or (eval-formula (disj-left f) evaluation) + (eval-formula (disj-right f) evaluation))] + [(conj? f) (and (eval-formula (conj-left f) evaluation) + (eval-formula (conj-right f) evaluation))] + [else (error "Zła formuła -- EVAL-FORMULA" f evaluation)])) + +(define (falsifable-eval? f) + (let* ((evaluations (gen-vals (free-vars f))) + (results (map (λ (evaluation) (eval-formula f evaluation)) evaluations))) + (ormap false? results))) + +(define (nff? f) + (cond [(lit? f) true] + [(neg? f) false] + [(conj? f) (and (nff? (conj-left f)) + (nff? (conj-right f)))] + [(disj? f) (and (nff? (disj-left f)) + (nff? (disj-right f)))] + [else (error "Zła formuła -- NFF?" f)])) + +(define (convert-to-nnf f) + (cond [(lit? f) f] + [(neg? f) (convert-negation (neg-subf f))] + [(conj? f) (make-conj (convert-to-nnf (conj-left f)) + (convert-to-nnf (conj-right f)))] + [(disj? f) (make-disj (convert-to-nnf (disj-left f)) + (convert-to-nnf (disj-right f)))] + [else (error "Zła formuła -- CONVERT" f)])) + +(define (convert-negation f) + (cond [(lit? f) + (if (var? f) + (make-neg f) + (neg-subf f))] + [(neg? f) (convert-to-nnf (neg-subf f))] + [(conj? f) (make-disj (convert-negation (conj-left f)) + (convert-negation (conj-right f)))] + [(disj? f) (make-conj (convert-negation (disj-left f)) + (convert-negation (disj-right f)))] + [else (error "Zła formuła -- CONVERT-NEGATION" f)])) + +(define (clause? x) + (and (list? x) + (andmap lit? x))) + +(define (clause-empty? x) + (and (clause? x) + (null? x))) + +(define (cnf? x) + (and (list? x) + (andmap clause? x))) + +(define (flatmap proc seq) + (foldl append null (map proc seq))) + +(define (convert-to-cnf f) + (define (convert f) + (cond [(lit? f) (list (list f))] + [(conj? f) (append (convert-to-cnf (conj-left f)) + (convert-to-cnf (conj-right f)))] + [(disj? f) + (let ((clause-left (convert-to-cnf (disj-left f))) + (clause-right (convert-to-cnf (disj-right f)))) + (flatmap (λ (clause) + (map (λ (clause2) + (append clause2 clause)) clause-left)) + clause-right))])) + (convert (convert-to-nnf f))) + +(define (falsifable-clause? clause) + (cond [(clause-empty? clause) true] + [(lit? (findf (λ (l) (equal? + l + (convert-to-nnf (make-neg (car clause))))) + clause)) false] + [else (falsifable-clause? (cdr clause))])) + +(define (falsifable-cnf? f) + (define (neg-value lit) + (if (var? lit) + (list lit false) + (list (neg-subf lit) true))) + (ormap (λ (clause) (if (falsifable-clause? clause) + (map neg-value clause) + false)) + (convert-to-cnf f)))
\ No newline at end of file diff --git a/semestr-2/racket/cw.rkt b/semestr-2/racket/cw.rkt new file mode 100644 index 0000000..f1e706f --- /dev/null +++ b/semestr-2/racket/cw.rkt @@ -0,0 +1,57 @@ +#lang racket + +(define (accumulate op initial sequence) + (if (null? sequence) + initial + (op (car sequence) + (accumulate op initial (cdr sequence))))) + +(define (horner-eval x coefficient-sequence) + (accumulate (lambda (this-coeff higher-terms) + (+ this-coeff (* x higher-terms))) + 0 + coefficient-sequence)) + + +(define (accumulate-n op init seqs) + (if (null? (car seqs)) + null + (cons (accumulate op init (map car seqs)) + (accumulate-n op init (map cdr seqs))))) + +(define (count-leaves t) + (accumulate + 0 (map (lambda (x) + (if (not (pair? x)) + 1 + (count-leaves x))) t))) + +(define (flatmap proc seq) + (accumulate append null (map proc seq))) + +(define (prime? x) (= (modulo x 2) 1)) + +(define (prime-sum? pair) + (prime? (+ (car pair) (cadr pair)))) + +(define (make-pair-sum pair) + (list (car pair) (cadr pair) (+ (car pair) (cadr pair)))) + +(define (enumerate-interval low high) + (if (> low high) + null + (cons low (enumerate-interval (+ 1 low) high)))) + +(define (unique-pairs n) + (flatmap (lambda (i) + (map (lambda (j) (list j i)) + (enumerate-interval 1 (- i 1)))) + (enumerate-interval 1 n))) + +(define (prime-sum-pairs n) + (map make-pair-sum + (filter prime-sum? (unique-pairs n)))) + +(define (is-eq-s? s triplet) + (= s (accumulate + 0 triplet))) + +(define
\ No newline at end of file diff --git a/semestr-2/racket/deriv.rkt b/semestr-2/racket/deriv.rkt new file mode 100644 index 0000000..0eef9d2 --- /dev/null +++ b/semestr-2/racket/deriv.rkt @@ -0,0 +1,47 @@ +#lang racket + +(define (variable? x) (symbol? x)) + +(define (same-variable? v1 v2) + (and (variable? v1) (variable? v2) (eq? v1 v2))) + +(define (=number? exp num) + (and (number? exp) (= exp num))) + +(define (make-sum a1 a2) + (cond ((=number? a1 0) a2) + ((=number? a2 0) a1) + ((and (number? a1) (number? a2) (+ a1 a2))) + (else (list '+ a1 a2)))) +(define (sum? x) + (and (pair? x) (eq? (car x) '+))) +(define (addend s) (cadr s)) +(define (augend s) (caddr s)) + +(define (make-product m1 m2) + (cond ((or (=number? m1 0) (=number? m2 0)) 0) + ((=number? m1 1) m2) + ((=number? m2 1) m1) + ((and (number? m1) (number? m2)) (* m1 m2)) + (else (list '* m1 m2)))) +(define (product? x) + (and (pair? x) (eq? (car x) '*))) +(define (multiplier p) (cadr p)) +(define (multiplicand p) (caddr p)) + +(define (deriv exp var) + (cond ((number? exp) 0) + ((variable? exp) + (if (same-variable? exp var) 1 0)) + ((sum? exp) + (make-sum (deriv (addend exp) var) + (deriv (augend exp) var))) + ((product? exp) + (make-sum + (make-product (multiplier exp) + (deriv (multiplicand exp) var)) + (make-product (deriv (multiplier exp) var) + (multiplicand exp)))) + (else + (error "Nieznany rodzaj wyrazenia -- DERIV" exp)))) +
\ No newline at end of file diff --git a/semestr-2/racket/egzamin/rozw2.txt b/semestr-2/racket/egzamin/rozw2.txt new file mode 100644 index 0000000..a70232e --- /dev/null +++ b/semestr-2/racket/egzamin/rozw2.txt @@ -0,0 +1 @@ +Zasada indukcji dla
\ No newline at end of file diff --git a/semestr-2/racket/egzamin/zad1.bak b/semestr-2/racket/egzamin/zad1.bak new file mode 100644 index 0000000..6f1f7b4 --- /dev/null +++ b/semestr-2/racket/egzamin/zad1.bak @@ -0,0 +1 @@ +#lang racket diff --git a/semestr-2/racket/egzamin/zad1.rkt b/semestr-2/racket/egzamin/zad1.rkt new file mode 100644 index 0000000..a90d2fd --- /dev/null +++ b/semestr-2/racket/egzamin/zad1.rkt @@ -0,0 +1,300 @@ +#lang racket + +;; ZADANIE 1 +;; ========= + +;; W tym zadaniu rozważamy język WHILE (w formie z grubsza +;; odpowiadającej tej z wykładu), z blokami deklarującymi zmienne o +;; lokalnym zakresie. + +;; Zadanie polega na dodaniu do języka procedur definiowanych na +;; zewnątrz głównego polecenia programu (podobnie jak w C, gdzie +;; główne polecenie odpowiadałoby procedurze main, czy Pascalu) — o +;; dowolnym wybranym przez siebie modelu działania. W tym celu należy: +;; · rozszerzyć składnię abstrakcyjną o składnię procedur i rozbudować odpowiednio składnię programów +;; · rozszerzyć procedurę parsowania +;; · rozszerzyć ewaluator +;; · *opisać* wybrany model działania procedur, w tym jego potencjalne zalety lub ograniczenia +;; Należy rozszerzyć poniższy szablon, a część słowną zadania umieścić +;; w komentarzu, podobnie jak niniejsze polecenie. + +;; Uwaga! Zadanie jest *bardzo* szeroko sformułowane, jest wiele +;; sensownych rozwiązań które stosowały liczne języki imperatywne w +;; historii — nie jest treścią zadania znalezienie *najlepszego*, +;; tylko swojego, które *rozumiecie*. Wybrany model działania procedur +;; *może* być relatywnie ubogi, jednak jeśli tak się zrobi, warto +;; pokazać że ma się tego świadomość w słownym opisie jego działania. + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) +(struct var-expr (name) #:transparent) +(struct call-expr (name args) #:transparent) +(struct return-expr (val) #:transparent) + +(define (operator? x) + (member x '(+ * - / > < = >= <=))) + +(define (keyword? x) + (member x '(skip while if := func call return))) + +(define (expr? e) + (match e + [(const v) + (integer? v)] + [(var-expr x) + (and (symbol? x) + (not (keyword? x)))] + [(binop op l r) + (and (operator? op) + (expr? l) + (expr? r))] + [_ false])) + +(struct skip () #:transparent) +(struct assign (id exp) #:transparent) +(struct if-cmd (exp ct cf) #:transparent) +(struct while (exp cmd) #:transparent) +(struct comp (left right) #:transparent) +(struct var-in (name expr cmd) #:transparent) +(struct function (name args cmd) #:transparent) + +(define (cmd? c) + (match c + [(skip) true] + [(assign x e) (and (symbol? x) (expr? e))] + [(if-cmd e ct cf) (and (expr? e) (cmd? ct) (cmd? cf))] + [(while e c) (and (expr? e) (cmd? c))] + [(comp c1 c2) (and (cmd? c1) (cmd? c2))] + [(var-in x e c) (and (symbol? x) (expr? e) (cmd? c))] + [(function f a c) (and (symbol? f) (list? a) (andmap symbol? a) (cmd? c))])) + +(define (prog? p) + (cmd? p)) + +(define (parse-expr p) + (cond + [(number? p) (const p)] + [(and (symbol? p) + (not (keyword? p))) + (var-expr p)] + [(and (list? p) + (= 3 (length p)) + (operator? (car p))) + (binop (first p) + (parse-expr (second p)) + (parse-expr (third p)))] + [(and (list? p) ; <------ wywołanie funkcji + (= (length p) 3) + (eq? (first p) 'call) + (symbol? (second p)) + (list? (third p))) + (call-expr (second p) (map parse-expr (third p)))] + [else false])) + +(define (parse-cmd q) + (cond + [(eq? q 'skip) (skip)] + [(and (list? q) + (= (length q) 3) + (eq? (second q) ':=)) + (assign (first q) (parse-expr (third q)))] + [(and (list? q) + (= (length q) 4) + (eq? (first q) 'if)) + (if-cmd (parse-expr (second q)) (parse-cmd (third q)) (parse-cmd (fourth q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'while)) + (while (parse-expr (second q)) (parse-cmd (third q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'var) + (list? (second q)) + (= (length (second q)) 2)) + (var-in (first (second q)) + (parse-expr (second (second q))) + (parse-cmd (third q)))] + [(and (list? q) ; <------ funkcje + (= (length q) 4) + (eq? (first q) 'func) + (symbol? (second q)) + (list? (third q)) + (andmap symbol? (third q))) + (function (second q) (third q) (parse-cmd (fourth q)))] + [(and (list? q) + (= (length q) 2) + (eq? (first q) 'return)) + (return-expr (parse-expr (second q)))] + [(and (list? q) + (>= (length q) 2)) + (desugar-comp (map parse-cmd q))] + [else false])) + +(define (desugar-comp cs) + (if (null? (cdr cs)) + (car cs) + (comp (car cs) + (desugar-comp (cdr cs))))) + +(define (value? v) + (number? v)) + +(struct mem (xs) #:transparent) + +(define (mem-lookup x m) + (define (assoc-lookup xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cdar xs)] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (mem-xs m))) + +(define (mem-defined? x m) ; <----------- !!! Sprawdz, czy x jest w ogole zdefiniowane + (define (assoc-lookup xs) + (cond + [(null? xs) #f] + [(eq? x (caar xs) #t)] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (mem-xs m))) + +(define (mem-update x v m) + (define (assoc-update xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cons (cons x v) (cdr xs))] + [else (cons (car xs) (assoc-update (cdr xs)))])) + (mem (assoc-update (mem-xs m)))) + +(define (mem-alloc x v m) + (mem (cons (cons x v) (mem-xs m)))) + +(define (mem-drop-last m) + (cond + [(null? (mem-xs m)) + (error "Deallocating from empty memory")] + [else + (mem (cdr (mem-xs m)))])) + +(define empty-mem + (mem null)) + +(define (op->proc op) + (match op + ['+ +] + ['- -] + ['* *] + ['/ /] + ['< (lambda (x y) (if (< x y) 1 0))] + ['> (lambda (x y) (if (> x y) 1 0))] + ['= (lambda (x y) (if (= x y) 1 0))] + ['<= (lambda (x y) (if (<= x y) 1 0))] + ['>= (lambda (x y) (if (>= x y) 1 0))] + )) + +;; zał: (expr? e) i (mem? m) jest prawdą +;; (value? (eval e m)) jest prawdą +(define (eval e m) + (match e + [(const v) v] + [(var-expr x) (mem-lookup x m)] + [(binop op l r) + (let ((vl (eval l m)) + (vr (eval r m)) + (p (op->proc op))) + (p vl vr))] + [(call-expr name args) + (match (mem-lookup name m) + [(clo func-args cmd) + (if (= (length args) (length func-args)) + (let* ([func-mem (assign-values args func-args m)] + [final-mem (eval-cmd cmd func-mem)] + [ret (mem-lookup 'RETURN final-mem)]) + (if ret + ret + (error "No return statement in function" name))) + (error "Arity mismatch, function" name "takes" (length func-args) ", got" (length args)))] + [else (error "Undefined function" name)])])) + +(define (assign-values args func-args mem) + (if (null? args) + mem + (assign-values (cdr args) (cdr func-args) (mem-alloc (car func-args) (eval (car args) mem) mem)))) + + +(struct clo (args cmd)) + +;; zał: (cmd? c) (mem? m) +;; (mem? (eval-cmd c m)) +(define (eval-cmd c m) + (if (mem-lookup 'RETURN m) + m + (match c + [(skip) m] + [(assign x e) (mem-update x (eval e m) m)] + [(if-cmd e ct cf) (if (= (eval e m) 0) + (eval-cmd cf m) + (eval-cmd ct m))] + [(while e cw) (if (= (eval e m) 0) + m + (let* ((m1 (eval-cmd cw m)) + (m2 (eval-cmd c m1))) + m2))] + [(comp c1 c2) (let* ((m1 (eval-cmd c1 m)) + (m2 (eval-cmd c2 m1))) + m2)] + [(var-in x e c) (let* ((v (eval e m)) + (m1 (mem-alloc x v m)) + (m2 (eval-cmd c m1))) + (mem-drop-last m2))] + [(function name args cmd) + (mem-alloc name (clo args cmd) m)] + [(return-expr val) + (mem-update 'RETURN (eval val m) m)] + [_ (error "Unknown command" c "— likely a syntax error")]))) + + +(define (eval-prog p m) + (let ((final-mem (eval-cmd p (mem-alloc 'RETURN #f m)))) + (with-handlers ([exn:fail? (lambda (v) (error "Undefined reference to main"))]) + (match (mem-lookup 'main final-mem) + [(clo args cmd) (mem-lookup 'RETURN (eval-cmd cmd final-mem))])))) + +(define WHILE_FACT + '({func decr (x) + {(x := (- x 1)) + (return x)}} + {func main () + {(i := 1) + (while (> t 0) + {(i := (* i t)) + (t := (call decr (t)))}) + (return i)}} + )) + +(define TEST + '({func decr (x) (return (- x 1))} + {func main () + (var (x 1) + {(x := (+ x 1)) + (return (call decr (x)))})})) + +(define TEST2 + '({func decr (x) (return (- x 1))} + {func main () (return (call decr (3)))})) + +(define TEST3 + '({func sth (x) + {(i := -1) + (return x)}} + {func main () + {(i := 2) + (return (call sth (i)))}})) + +(define TEST4 + '(func f () + {return 1})) + +(define (fact n) + (let* ([init-env (mem-alloc 'i 1 (mem-alloc 't n empty-mem))]) + (eval-prog (parse-cmd WHILE_FACT) init-env))) + diff --git a/semestr-2/racket/egzamin/zad1a.bak b/semestr-2/racket/egzamin/zad1a.bak new file mode 100644 index 0000000..a90d2fd --- /dev/null +++ b/semestr-2/racket/egzamin/zad1a.bak @@ -0,0 +1,300 @@ +#lang racket + +;; ZADANIE 1 +;; ========= + +;; W tym zadaniu rozważamy język WHILE (w formie z grubsza +;; odpowiadającej tej z wykładu), z blokami deklarującymi zmienne o +;; lokalnym zakresie. + +;; Zadanie polega na dodaniu do języka procedur definiowanych na +;; zewnątrz głównego polecenia programu (podobnie jak w C, gdzie +;; główne polecenie odpowiadałoby procedurze main, czy Pascalu) — o +;; dowolnym wybranym przez siebie modelu działania. W tym celu należy: +;; · rozszerzyć składnię abstrakcyjną o składnię procedur i rozbudować odpowiednio składnię programów +;; · rozszerzyć procedurę parsowania +;; · rozszerzyć ewaluator +;; · *opisać* wybrany model działania procedur, w tym jego potencjalne zalety lub ograniczenia +;; Należy rozszerzyć poniższy szablon, a część słowną zadania umieścić +;; w komentarzu, podobnie jak niniejsze polecenie. + +;; Uwaga! Zadanie jest *bardzo* szeroko sformułowane, jest wiele +;; sensownych rozwiązań które stosowały liczne języki imperatywne w +;; historii — nie jest treścią zadania znalezienie *najlepszego*, +;; tylko swojego, które *rozumiecie*. Wybrany model działania procedur +;; *może* być relatywnie ubogi, jednak jeśli tak się zrobi, warto +;; pokazać że ma się tego świadomość w słownym opisie jego działania. + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) +(struct var-expr (name) #:transparent) +(struct call-expr (name args) #:transparent) +(struct return-expr (val) #:transparent) + +(define (operator? x) + (member x '(+ * - / > < = >= <=))) + +(define (keyword? x) + (member x '(skip while if := func call return))) + +(define (expr? e) + (match e + [(const v) + (integer? v)] + [(var-expr x) + (and (symbol? x) + (not (keyword? x)))] + [(binop op l r) + (and (operator? op) + (expr? l) + (expr? r))] + [_ false])) + +(struct skip () #:transparent) +(struct assign (id exp) #:transparent) +(struct if-cmd (exp ct cf) #:transparent) +(struct while (exp cmd) #:transparent) +(struct comp (left right) #:transparent) +(struct var-in (name expr cmd) #:transparent) +(struct function (name args cmd) #:transparent) + +(define (cmd? c) + (match c + [(skip) true] + [(assign x e) (and (symbol? x) (expr? e))] + [(if-cmd e ct cf) (and (expr? e) (cmd? ct) (cmd? cf))] + [(while e c) (and (expr? e) (cmd? c))] + [(comp c1 c2) (and (cmd? c1) (cmd? c2))] + [(var-in x e c) (and (symbol? x) (expr? e) (cmd? c))] + [(function f a c) (and (symbol? f) (list? a) (andmap symbol? a) (cmd? c))])) + +(define (prog? p) + (cmd? p)) + +(define (parse-expr p) + (cond + [(number? p) (const p)] + [(and (symbol? p) + (not (keyword? p))) + (var-expr p)] + [(and (list? p) + (= 3 (length p)) + (operator? (car p))) + (binop (first p) + (parse-expr (second p)) + (parse-expr (third p)))] + [(and (list? p) ; <------ wywołanie funkcji + (= (length p) 3) + (eq? (first p) 'call) + (symbol? (second p)) + (list? (third p))) + (call-expr (second p) (map parse-expr (third p)))] + [else false])) + +(define (parse-cmd q) + (cond + [(eq? q 'skip) (skip)] + [(and (list? q) + (= (length q) 3) + (eq? (second q) ':=)) + (assign (first q) (parse-expr (third q)))] + [(and (list? q) + (= (length q) 4) + (eq? (first q) 'if)) + (if-cmd (parse-expr (second q)) (parse-cmd (third q)) (parse-cmd (fourth q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'while)) + (while (parse-expr (second q)) (parse-cmd (third q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'var) + (list? (second q)) + (= (length (second q)) 2)) + (var-in (first (second q)) + (parse-expr (second (second q))) + (parse-cmd (third q)))] + [(and (list? q) ; <------ funkcje + (= (length q) 4) + (eq? (first q) 'func) + (symbol? (second q)) + (list? (third q)) + (andmap symbol? (third q))) + (function (second q) (third q) (parse-cmd (fourth q)))] + [(and (list? q) + (= (length q) 2) + (eq? (first q) 'return)) + (return-expr (parse-expr (second q)))] + [(and (list? q) + (>= (length q) 2)) + (desugar-comp (map parse-cmd q))] + [else false])) + +(define (desugar-comp cs) + (if (null? (cdr cs)) + (car cs) + (comp (car cs) + (desugar-comp (cdr cs))))) + +(define (value? v) + (number? v)) + +(struct mem (xs) #:transparent) + +(define (mem-lookup x m) + (define (assoc-lookup xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cdar xs)] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (mem-xs m))) + +(define (mem-defined? x m) ; <----------- !!! Sprawdz, czy x jest w ogole zdefiniowane + (define (assoc-lookup xs) + (cond + [(null? xs) #f] + [(eq? x (caar xs) #t)] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (mem-xs m))) + +(define (mem-update x v m) + (define (assoc-update xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cons (cons x v) (cdr xs))] + [else (cons (car xs) (assoc-update (cdr xs)))])) + (mem (assoc-update (mem-xs m)))) + +(define (mem-alloc x v m) + (mem (cons (cons x v) (mem-xs m)))) + +(define (mem-drop-last m) + (cond + [(null? (mem-xs m)) + (error "Deallocating from empty memory")] + [else + (mem (cdr (mem-xs m)))])) + +(define empty-mem + (mem null)) + +(define (op->proc op) + (match op + ['+ +] + ['- -] + ['* *] + ['/ /] + ['< (lambda (x y) (if (< x y) 1 0))] + ['> (lambda (x y) (if (> x y) 1 0))] + ['= (lambda (x y) (if (= x y) 1 0))] + ['<= (lambda (x y) (if (<= x y) 1 0))] + ['>= (lambda (x y) (if (>= x y) 1 0))] + )) + +;; zał: (expr? e) i (mem? m) jest prawdą +;; (value? (eval e m)) jest prawdą +(define (eval e m) + (match e + [(const v) v] + [(var-expr x) (mem-lookup x m)] + [(binop op l r) + (let ((vl (eval l m)) + (vr (eval r m)) + (p (op->proc op))) + (p vl vr))] + [(call-expr name args) + (match (mem-lookup name m) + [(clo func-args cmd) + (if (= (length args) (length func-args)) + (let* ([func-mem (assign-values args func-args m)] + [final-mem (eval-cmd cmd func-mem)] + [ret (mem-lookup 'RETURN final-mem)]) + (if ret + ret + (error "No return statement in function" name))) + (error "Arity mismatch, function" name "takes" (length func-args) ", got" (length args)))] + [else (error "Undefined function" name)])])) + +(define (assign-values args func-args mem) + (if (null? args) + mem + (assign-values (cdr args) (cdr func-args) (mem-alloc (car func-args) (eval (car args) mem) mem)))) + + +(struct clo (args cmd)) + +;; zał: (cmd? c) (mem? m) +;; (mem? (eval-cmd c m)) +(define (eval-cmd c m) + (if (mem-lookup 'RETURN m) + m + (match c + [(skip) m] + [(assign x e) (mem-update x (eval e m) m)] + [(if-cmd e ct cf) (if (= (eval e m) 0) + (eval-cmd cf m) + (eval-cmd ct m))] + [(while e cw) (if (= (eval e m) 0) + m + (let* ((m1 (eval-cmd cw m)) + (m2 (eval-cmd c m1))) + m2))] + [(comp c1 c2) (let* ((m1 (eval-cmd c1 m)) + (m2 (eval-cmd c2 m1))) + m2)] + [(var-in x e c) (let* ((v (eval e m)) + (m1 (mem-alloc x v m)) + (m2 (eval-cmd c m1))) + (mem-drop-last m2))] + [(function name args cmd) + (mem-alloc name (clo args cmd) m)] + [(return-expr val) + (mem-update 'RETURN (eval val m) m)] + [_ (error "Unknown command" c "— likely a syntax error")]))) + + +(define (eval-prog p m) + (let ((final-mem (eval-cmd p (mem-alloc 'RETURN #f m)))) + (with-handlers ([exn:fail? (lambda (v) (error "Undefined reference to main"))]) + (match (mem-lookup 'main final-mem) + [(clo args cmd) (mem-lookup 'RETURN (eval-cmd cmd final-mem))])))) + +(define WHILE_FACT + '({func decr (x) + {(x := (- x 1)) + (return x)}} + {func main () + {(i := 1) + (while (> t 0) + {(i := (* i t)) + (t := (call decr (t)))}) + (return i)}} + )) + +(define TEST + '({func decr (x) (return (- x 1))} + {func main () + (var (x 1) + {(x := (+ x 1)) + (return (call decr (x)))})})) + +(define TEST2 + '({func decr (x) (return (- x 1))} + {func main () (return (call decr (3)))})) + +(define TEST3 + '({func sth (x) + {(i := -1) + (return x)}} + {func main () + {(i := 2) + (return (call sth (i)))}})) + +(define TEST4 + '(func f () + {return 1})) + +(define (fact n) + (let* ([init-env (mem-alloc 'i 1 (mem-alloc 't n empty-mem))]) + (eval-prog (parse-cmd WHILE_FACT) init-env))) + diff --git a/semestr-2/racket/egzamin/zad1a.rkt b/semestr-2/racket/egzamin/zad1a.rkt new file mode 100644 index 0000000..a587359 --- /dev/null +++ b/semestr-2/racket/egzamin/zad1a.rkt @@ -0,0 +1,314 @@ +#lang racket + +;; ZADANIE 1 +;; ========= + +;; W tym zadaniu rozważamy język WHILE (w formie z grubsza +;; odpowiadającej tej z wykładu), z blokami deklarującymi zmienne o +;; lokalnym zakresie. + +;; Zadanie polega na dodaniu do języka procedur definiowanych na +;; zewnątrz głównego polecenia programu (podobnie jak w C, gdzie +;; główne polecenie odpowiadałoby procedurze main, czy Pascalu) — o +;; dowolnym wybranym przez siebie modelu działania. W tym celu należy: +;; · rozszerzyć składnię abstrakcyjną o składnię procedur i rozbudować odpowiednio składnię programów +;; · rozszerzyć procedurę parsowania +;; · rozszerzyć ewaluator +;; · *opisać* wybrany model działania procedur, w tym jego potencjalne zalety lub ograniczenia +;; Należy rozszerzyć poniższy szablon, a część słowną zadania umieścić +;; w komentarzu, podobnie jak niniejsze polecenie. + +;; Uwaga! Zadanie jest *bardzo* szeroko sformułowane, jest wiele +;; sensownych rozwiązań które stosowały liczne języki imperatywne w +;; historii — nie jest treścią zadania znalezienie *najlepszego*, +;; tylko swojego, które *rozumiecie*. Wybrany model działania procedur +;; *może* być relatywnie ubogi, jednak jeśli tak się zrobi, warto +;; pokazać że ma się tego świadomość w słownym opisie jego działania. + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) +(struct var-expr (name) #:transparent) +(struct call-expr (name args) #:transparent) +(struct return-expr (val) #:transparent) + +(define (operator? x) + (member x '(+ * - / > < = >= <=))) + +(define (keyword? x) + (member x '(skip while if := func call return))) + +(define (expr? e) + (match e + [(const v) + (integer? v)] + [(var-expr x) + (and (symbol? x) + (not (keyword? x)))] + [(binop op l r) + (and (operator? op) + (expr? l) + (expr? r))] + [_ false])) + +(struct skip () #:transparent) +(struct assign (id exp) #:transparent) +(struct if-cmd (exp ct cf) #:transparent) +(struct while (exp cmd) #:transparent) +(struct comp (left right) #:transparent) +(struct var-in (name expr cmd) #:transparent) +(struct function (name args cmd) #:transparent) + +(define (cmd? c) + (match c + [(skip) true] + [(assign x e) (and (symbol? x) (expr? e))] + [(if-cmd e ct cf) (and (expr? e) (cmd? ct) (cmd? cf))] + [(while e c) (and (expr? e) (cmd? c))] + [(comp c1 c2) (and (cmd? c1) (cmd? c2))] + [(var-in x e c) (and (symbol? x) (expr? e) (cmd? c))] + [(function f a c) (and (symbol? f) (list? a) (andmap symbol? a) (cmd? c))])) + +(define (prog? p) + (cmd? p)) + +(define (parse-expr p) + (cond + [(number? p) (const p)] + [(and (symbol? p) + (not (keyword? p))) + (var-expr p)] + [(and (list? p) + (= 3 (length p)) + (operator? (car p))) + (binop (first p) + (parse-expr (second p)) + (parse-expr (third p)))] + [(and (list? p) ; <------ wywołanie funkcji + (= (length p) 3) + (eq? (first p) 'call) + (symbol? (second p)) + (list? (third p))) + (call-expr (second p) (map parse-expr (third p)))] + [else false])) + +(define (parse-cmd q) + (cond + [(eq? q 'skip) (skip)] + [(and (list? q) + (= (length q) 3) + (eq? (second q) ':=)) + (assign (first q) (parse-expr (third q)))] + [(and (list? q) + (= (length q) 4) + (eq? (first q) 'if)) + (if-cmd (parse-expr (second q)) (parse-cmd (third q)) (parse-cmd (fourth q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'while)) + (while (parse-expr (second q)) (parse-cmd (third q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'var) + (list? (second q)) + (= (length (second q)) 2)) + (var-in (first (second q)) + (parse-expr (second (second q))) + (parse-cmd (third q)))] + [(and (list? q) ; <------ funkcje + (= (length q) 4) + (eq? (first q) 'func) + (symbol? (second q)) + (list? (third q)) + (andmap symbol? (third q))) + (function (second q) (third q) (parse-cmd (fourth q)))] + [(and (list? q) + (= (length q) 2) + (eq? (first q) 'return)) + (return-expr (parse-expr (second q)))] + [(and (list? q) + (>= (length q) 2)) + (desugar-comp (map parse-cmd q))] + [else false])) + +(define (desugar-comp cs) + (if (null? (cdr cs)) + (car cs) + (comp (car cs) + (desugar-comp (cdr cs))))) + +(define (value? v) + (number? v)) + +(struct mem (xs) #:transparent) + +(define (mem-lookup x m) + (define (assoc-lookup xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cdar xs)] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (mem-xs m))) + +(define (mem-defined? x m) ; <----------- !!! Sprawdz, czy x jest w ogole zdefiniowane + (define (assoc-lookup xs) + (cond + [(null? xs) #f] + [(eq? x (caar xs) #t)] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (mem-xs m))) + +(define (mem-update x v m) + (define (assoc-update xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cons (cons x v) (cdr xs))] + [else (cons (car xs) (assoc-update (cdr xs)))])) + (mem (assoc-update (mem-xs m)))) + +(define (mem-alloc x v m) + (mem (cons (cons x v) (mem-xs m)))) + +(define (mem-drop-last m) + (cond + [(null? (mem-xs m)) + (error "Deallocating from empty memory")] + [else + (mem (cdr (mem-xs m)))])) + +(define empty-mem + (mem null)) + +(define (op->proc op) + (match op + ['+ +] + ['- -] + ['* *] + ['/ /] + ['< (lambda (x y) (if (< x y) 1 0))] + ['> (lambda (x y) (if (> x y) 1 0))] + ['= (lambda (x y) (if (= x y) 1 0))] + ['<= (lambda (x y) (if (<= x y) 1 0))] + ['>= (lambda (x y) (if (>= x y) 1 0))] + )) + +;; zał: (expr? e) i (mem? m) jest prawdą +;; (value? (eval e m)) jest prawdą +(define (eval e m) + (match e + [(const v) v] + [(var-expr x) (mem-lookup x m)] + [(binop op l r) + (let ((vl (eval l m)) + (vr (eval r m)) + (p (op->proc op))) + (p vl vr))] + [(call-expr name args) + (match (mem-lookup name m) + [(clo func-args cmd) + (if (= (length args) (length func-args)) + (let* ([func-mem (assign-values args func-args m)] + [final-mem (eval-cmd cmd func-mem)] + [ret (mem-lookup 'RETURN final-mem)]) + (if ret + ret + (error "No return statement in function" name))) + (error "Arity mismatch, function" name "takes" (length func-args) ", got" (length args)))] + [else (error "Undefined function" name)])])) + +(define (assign-values args func-args mem) + (define (iter args func-args new-mem) + (if (null? args) + new-mem + (iter (cdr args) (cdr func-args) (mem-alloc (car func-args) (eval (car args) mem) new-mem)))) + (iter args func-args mem)) + + +(struct clo (args cmd)) + +;; zał: (cmd? c) (mem? m) +;; (mem? (eval-cmd c m)) +(define (eval-cmd c m) + (if (mem-lookup 'RETURN m) + m + (match c + [(skip) m] + [(assign x e) (mem-update x (eval e m) m)] + [(if-cmd e ct cf) (if (= (eval e m) 0) + (eval-cmd cf m) + (eval-cmd ct m))] + [(while e cw) (if (= (eval e m) 0) + m + (let* ((m1 (eval-cmd cw m)) + (m2 (eval-cmd c m1))) + m2))] + [(comp c1 c2) (let* ((m1 (eval-cmd c1 m)) + (m2 (eval-cmd c2 m1))) + m2)] + [(var-in x e c) (let* ((v (eval e m)) + (m1 (mem-alloc x v m)) + (m2 (eval-cmd c m1))) + (mem-drop-last m2))] + [(function name args cmd) + (mem-alloc name (clo args cmd) m)] + [(return-expr val) + (mem-update 'RETURN (eval val m) m)] + [_ (error "Unknown command" c "— likely a syntax error")]))) + + +(define (eval-prog p m) + (let ((final-mem (eval-cmd p (mem-alloc 'RETURN #f m)))) + (with-handlers ([exn:fail? (lambda (v) (error "Undefined reference to main"))]) + (match (mem-lookup 'main final-mem) + [(clo args cmd) (mem-lookup 'RETURN (eval-cmd cmd final-mem))])))) + +(define WHILE_FACT + '({func decr (x) + {(x := (- x 1)) + (return x)}} + {func main () + {(i := 1) + (while (> t 0) + {(i := (* i t)) + (t := (call decr (t)))}) + (return i)}} + )) + +(define (fact n) + (let* ([init-env (mem-alloc 'i 1 (mem-alloc 't n empty-mem))]) + (eval-prog (parse-cmd WHILE_FACT) init-env))) + +(define TEST + '({func decr (x) (return (- x 1))} + {func main () + (var (x 1) + {(x := (+ x 1)) + (return (call decr (x)))})})) + +(define TEST2 + '({func decr (x) (return (- x 1))} + {func main () (return (call decr (3)))})) + +(define TEST3 + '({func sth (x) + {(i := -1) + (return x)}} + {func main () + {(i := 2) + (return (call sth (i)))}})) + +(define TEST4 + '(func f () + {return 1})) + +(define TEST5 + '({func f1 (x y z) + (return y)} + {func f2 (x y z) + (return (+ (+ x y) z))} + {func main () + {(if (> 4 3) + (var (x 2) + (return (call f1 (1 x 3)))) + (x := 5)) + (return (call f2 (x 3 4)))}})) +
\ No newline at end of file diff --git a/semestr-2/racket/egzamin/zad1b.bak b/semestr-2/racket/egzamin/zad1b.bak new file mode 100644 index 0000000..a587359 --- /dev/null +++ b/semestr-2/racket/egzamin/zad1b.bak @@ -0,0 +1,314 @@ +#lang racket + +;; ZADANIE 1 +;; ========= + +;; W tym zadaniu rozważamy język WHILE (w formie z grubsza +;; odpowiadającej tej z wykładu), z blokami deklarującymi zmienne o +;; lokalnym zakresie. + +;; Zadanie polega na dodaniu do języka procedur definiowanych na +;; zewnątrz głównego polecenia programu (podobnie jak w C, gdzie +;; główne polecenie odpowiadałoby procedurze main, czy Pascalu) — o +;; dowolnym wybranym przez siebie modelu działania. W tym celu należy: +;; · rozszerzyć składnię abstrakcyjną o składnię procedur i rozbudować odpowiednio składnię programów +;; · rozszerzyć procedurę parsowania +;; · rozszerzyć ewaluator +;; · *opisać* wybrany model działania procedur, w tym jego potencjalne zalety lub ograniczenia +;; Należy rozszerzyć poniższy szablon, a część słowną zadania umieścić +;; w komentarzu, podobnie jak niniejsze polecenie. + +;; Uwaga! Zadanie jest *bardzo* szeroko sformułowane, jest wiele +;; sensownych rozwiązań które stosowały liczne języki imperatywne w +;; historii — nie jest treścią zadania znalezienie *najlepszego*, +;; tylko swojego, które *rozumiecie*. Wybrany model działania procedur +;; *może* być relatywnie ubogi, jednak jeśli tak się zrobi, warto +;; pokazać że ma się tego świadomość w słownym opisie jego działania. + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) +(struct var-expr (name) #:transparent) +(struct call-expr (name args) #:transparent) +(struct return-expr (val) #:transparent) + +(define (operator? x) + (member x '(+ * - / > < = >= <=))) + +(define (keyword? x) + (member x '(skip while if := func call return))) + +(define (expr? e) + (match e + [(const v) + (integer? v)] + [(var-expr x) + (and (symbol? x) + (not (keyword? x)))] + [(binop op l r) + (and (operator? op) + (expr? l) + (expr? r))] + [_ false])) + +(struct skip () #:transparent) +(struct assign (id exp) #:transparent) +(struct if-cmd (exp ct cf) #:transparent) +(struct while (exp cmd) #:transparent) +(struct comp (left right) #:transparent) +(struct var-in (name expr cmd) #:transparent) +(struct function (name args cmd) #:transparent) + +(define (cmd? c) + (match c + [(skip) true] + [(assign x e) (and (symbol? x) (expr? e))] + [(if-cmd e ct cf) (and (expr? e) (cmd? ct) (cmd? cf))] + [(while e c) (and (expr? e) (cmd? c))] + [(comp c1 c2) (and (cmd? c1) (cmd? c2))] + [(var-in x e c) (and (symbol? x) (expr? e) (cmd? c))] + [(function f a c) (and (symbol? f) (list? a) (andmap symbol? a) (cmd? c))])) + +(define (prog? p) + (cmd? p)) + +(define (parse-expr p) + (cond + [(number? p) (const p)] + [(and (symbol? p) + (not (keyword? p))) + (var-expr p)] + [(and (list? p) + (= 3 (length p)) + (operator? (car p))) + (binop (first p) + (parse-expr (second p)) + (parse-expr (third p)))] + [(and (list? p) ; <------ wywołanie funkcji + (= (length p) 3) + (eq? (first p) 'call) + (symbol? (second p)) + (list? (third p))) + (call-expr (second p) (map parse-expr (third p)))] + [else false])) + +(define (parse-cmd q) + (cond + [(eq? q 'skip) (skip)] + [(and (list? q) + (= (length q) 3) + (eq? (second q) ':=)) + (assign (first q) (parse-expr (third q)))] + [(and (list? q) + (= (length q) 4) + (eq? (first q) 'if)) + (if-cmd (parse-expr (second q)) (parse-cmd (third q)) (parse-cmd (fourth q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'while)) + (while (parse-expr (second q)) (parse-cmd (third q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'var) + (list? (second q)) + (= (length (second q)) 2)) + (var-in (first (second q)) + (parse-expr (second (second q))) + (parse-cmd (third q)))] + [(and (list? q) ; <------ funkcje + (= (length q) 4) + (eq? (first q) 'func) + (symbol? (second q)) + (list? (third q)) + (andmap symbol? (third q))) + (function (second q) (third q) (parse-cmd (fourth q)))] + [(and (list? q) + (= (length q) 2) + (eq? (first q) 'return)) + (return-expr (parse-expr (second q)))] + [(and (list? q) + (>= (length q) 2)) + (desugar-comp (map parse-cmd q))] + [else false])) + +(define (desugar-comp cs) + (if (null? (cdr cs)) + (car cs) + (comp (car cs) + (desugar-comp (cdr cs))))) + +(define (value? v) + (number? v)) + +(struct mem (xs) #:transparent) + +(define (mem-lookup x m) + (define (assoc-lookup xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cdar xs)] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (mem-xs m))) + +(define (mem-defined? x m) ; <----------- !!! Sprawdz, czy x jest w ogole zdefiniowane + (define (assoc-lookup xs) + (cond + [(null? xs) #f] + [(eq? x (caar xs) #t)] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (mem-xs m))) + +(define (mem-update x v m) + (define (assoc-update xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cons (cons x v) (cdr xs))] + [else (cons (car xs) (assoc-update (cdr xs)))])) + (mem (assoc-update (mem-xs m)))) + +(define (mem-alloc x v m) + (mem (cons (cons x v) (mem-xs m)))) + +(define (mem-drop-last m) + (cond + [(null? (mem-xs m)) + (error "Deallocating from empty memory")] + [else + (mem (cdr (mem-xs m)))])) + +(define empty-mem + (mem null)) + +(define (op->proc op) + (match op + ['+ +] + ['- -] + ['* *] + ['/ /] + ['< (lambda (x y) (if (< x y) 1 0))] + ['> (lambda (x y) (if (> x y) 1 0))] + ['= (lambda (x y) (if (= x y) 1 0))] + ['<= (lambda (x y) (if (<= x y) 1 0))] + ['>= (lambda (x y) (if (>= x y) 1 0))] + )) + +;; zał: (expr? e) i (mem? m) jest prawdą +;; (value? (eval e m)) jest prawdą +(define (eval e m) + (match e + [(const v) v] + [(var-expr x) (mem-lookup x m)] + [(binop op l r) + (let ((vl (eval l m)) + (vr (eval r m)) + (p (op->proc op))) + (p vl vr))] + [(call-expr name args) + (match (mem-lookup name m) + [(clo func-args cmd) + (if (= (length args) (length func-args)) + (let* ([func-mem (assign-values args func-args m)] + [final-mem (eval-cmd cmd func-mem)] + [ret (mem-lookup 'RETURN final-mem)]) + (if ret + ret + (error "No return statement in function" name))) + (error "Arity mismatch, function" name "takes" (length func-args) ", got" (length args)))] + [else (error "Undefined function" name)])])) + +(define (assign-values args func-args mem) + (define (iter args func-args new-mem) + (if (null? args) + new-mem + (iter (cdr args) (cdr func-args) (mem-alloc (car func-args) (eval (car args) mem) new-mem)))) + (iter args func-args mem)) + + +(struct clo (args cmd)) + +;; zał: (cmd? c) (mem? m) +;; (mem? (eval-cmd c m)) +(define (eval-cmd c m) + (if (mem-lookup 'RETURN m) + m + (match c + [(skip) m] + [(assign x e) (mem-update x (eval e m) m)] + [(if-cmd e ct cf) (if (= (eval e m) 0) + (eval-cmd cf m) + (eval-cmd ct m))] + [(while e cw) (if (= (eval e m) 0) + m + (let* ((m1 (eval-cmd cw m)) + (m2 (eval-cmd c m1))) + m2))] + [(comp c1 c2) (let* ((m1 (eval-cmd c1 m)) + (m2 (eval-cmd c2 m1))) + m2)] + [(var-in x e c) (let* ((v (eval e m)) + (m1 (mem-alloc x v m)) + (m2 (eval-cmd c m1))) + (mem-drop-last m2))] + [(function name args cmd) + (mem-alloc name (clo args cmd) m)] + [(return-expr val) + (mem-update 'RETURN (eval val m) m)] + [_ (error "Unknown command" c "— likely a syntax error")]))) + + +(define (eval-prog p m) + (let ((final-mem (eval-cmd p (mem-alloc 'RETURN #f m)))) + (with-handlers ([exn:fail? (lambda (v) (error "Undefined reference to main"))]) + (match (mem-lookup 'main final-mem) + [(clo args cmd) (mem-lookup 'RETURN (eval-cmd cmd final-mem))])))) + +(define WHILE_FACT + '({func decr (x) + {(x := (- x 1)) + (return x)}} + {func main () + {(i := 1) + (while (> t 0) + {(i := (* i t)) + (t := (call decr (t)))}) + (return i)}} + )) + +(define (fact n) + (let* ([init-env (mem-alloc 'i 1 (mem-alloc 't n empty-mem))]) + (eval-prog (parse-cmd WHILE_FACT) init-env))) + +(define TEST + '({func decr (x) (return (- x 1))} + {func main () + (var (x 1) + {(x := (+ x 1)) + (return (call decr (x)))})})) + +(define TEST2 + '({func decr (x) (return (- x 1))} + {func main () (return (call decr (3)))})) + +(define TEST3 + '({func sth (x) + {(i := -1) + (return x)}} + {func main () + {(i := 2) + (return (call sth (i)))}})) + +(define TEST4 + '(func f () + {return 1})) + +(define TEST5 + '({func f1 (x y z) + (return y)} + {func f2 (x y z) + (return (+ (+ x y) z))} + {func main () + {(if (> 4 3) + (var (x 2) + (return (call f1 (1 x 3)))) + (x := 5)) + (return (call f2 (x 3 4)))}})) +
\ No newline at end of file diff --git a/semestr-2/racket/egzamin/zad1b.rkt b/semestr-2/racket/egzamin/zad1b.rkt new file mode 100644 index 0000000..628619f --- /dev/null +++ b/semestr-2/racket/egzamin/zad1b.rkt @@ -0,0 +1,482 @@ +#lang racket + + + +;; Oświadczam, że rozwiązanie zadania egzaminacyjnego przygotowałem +;; w pełni samodzielnie, korzystając wyłącznie z materiałów do wykładu, +;; notatek, podręcznika, oraz materiałów zacytowanych w treści rozwiązania. +;; Oświadczam że nie korzystałem w żadnej formie z pomocy osób trzecich +;; w przygotowaniu rozwiązania ani też takiej pomocy nie udzielałem +;; i nie udostępniałem nikomu swojego rozwiązania. + +;; ZADANIE 1 +;; ========= + +;; W tym zadaniu rozważamy język WHILE (w formie z grubsza +;; odpowiadającej tej z wykładu), z blokami deklarującymi zmienne o +;; lokalnym zakresie. + +;; Zadanie polega na dodaniu do języka procedur definiowanych na +;; zewnątrz głównego polecenia programu (podobnie jak w C, gdzie +;; główne polecenie odpowiadałoby procedurze main, czy Pascalu) — o +;; dowolnym wybranym przez siebie modelu działania. W tym celu należy: +;; · rozszerzyć składnię abstrakcyjną o składnię procedur i rozbudować odpowiednio składnię programów +;; · rozszerzyć procedurę parsowania +;; · rozszerzyć ewaluator +;; · *opisać* wybrany model działania procedur, w tym jego potencjalne zalety lub ograniczenia +;; Należy rozszerzyć poniższy szablon, a część słowną zadania umieścić +;; w komentarzu, podobnie jak niniejsze polecenie. + +;; Uwaga! Zadanie jest *bardzo* szeroko sformułowane, jest wiele +;; sensownych rozwiązań które stosowały liczne języki imperatywne w +;; historii — nie jest treścią zadania znalezienie *najlepszego*, +;; tylko swojego, które *rozumiecie*. Wybrany model działania procedur +;; *może* być relatywnie ubogi, jednak jeśli tak się zrobi, warto +;; pokazać że ma się tego świadomość w słownym opisie jego działania. + + + + + + + +;; Postanowiłem, że struktura programów w moim języku będzie miała trochę z pythona i trochę z C. +;; Istotną decyzją którą podjąłem jest to, że wszystkie funkcje w naszym języku muszą zwracać +;; jakąś wartość (zawsze zwracają inta), łącznie z funkcją main, przy pomocy dyrektywy "return". +;; To, co zwraca main, jest tym co zwraca +;; cały program (z małym wyjątkiem, ale o tym później). Okazało się, że takie podejście +;; do sprawy jest bardzo wygodne -- nie musiałem się dzięki temu nawet przejmować +;; osobnym implementowaniem funkcji rekurencyjnych, wzajemnie rekurencyjnych +;; czy nawet zagnieżdżonych, a do tego można definiować funkcje w dowolnej kolejności! +;; Co więcej, funkcje przyjmują dowolnie wiele argumentów, również 0. +;; On top of that, do funkcji można przekazywać cokolwiek co ewaluuje się do wartości +;; Czyli mozna przekazywać wartości zmiennych, jak i dowolne wyrażenia! + +;; Oto przykładowy kod, po którym raczej jasno widać w jak wygląda nowa składnia: +(define BINOM '({func main () + (return (call binom (N K)))} + {func fact (t) + (if (= t 0) + (return 1) + ({func decr (x) (return (- x 1))} + (return (* t (call fact ((call decr (t))))))))} + {func binom (n k) + (if (= k 0) + (return 1) + (var (num (call fact (n))) + (var (den (* (call fact (k)) (call fact ((- n k))))) + (return (/ num den)))))} + )) +(define (bin n k) + (eval-prog (parse-cmd BINOM) (mem-alloc 'i 1 (mem-alloc 'N n (mem-alloc 'K k empty-mem))))) +;; Specjalnie trochę pokomplikowałem, ale widać featury naszego języka. + +;; Jak to w ogóle działa? + +;; Za każdym razem, kiedy definiuję funkcję, to do środowiska dodaję parę (nazwa funkcji . clo), +;; gdzie clo jest takim quasi-domknięciem, jest to po prostu struktura trzymająca nazwy +;; argumentów funkcji oraz jej ciało. Właśnie takie podejście bardzo dobrze +;; załatwiło łatwość w definiowaniu funkcji rekurencyjnych oraz wzajemnie rekurencyjnych i +;; zagnieżdżonych -- żadna funkcja nie zostanie wywołana, dopóki nie wywołam maina, +;; a tego wywołam dopiero po zewaluowaniu wszystkich definicji (tym samym dodaniu ich do środowiska). + +;; Takie podejście ma trochę problemów, chyba największym z nich jest to, że nie ma możliwości +;; zmiany wartości globalnych wewnątrz funkcji. Tj. możemy je zmieniać, ale zmiany będą +;; widoczne jedynie w jej lokalnym zakresie. +;; W zasadzie nie jest to aż tak bolesne -- globalne zmienne możemy traktować po prostu +;; jak argumenty wywołania funkcji main. + +;; Wywoływać funkcję mogę tylko za pomocą specjalnego wyrażenia call, +;; które jako pierwszy argument +;; przyjmuje nazwę funkcji, a jako drugi przyjmuje listę argumentów. +;; Żeby wiedzieć jak działa call, spójrzmy najpierw jak działa return. + +;; return napisane jest tak, że jeśli w jakimkolwiek miejscu funkcji +;; się na niego trafi, to reszta funkcji nie jest już wywoływana +;; (czyli tak jakbyśmy sie spodziewali). Jak on w sumie działa? +;; Na samym początku eval-prog, zanim zacznę w ogóle ewaluować definicje funkcji, +;; dodaje do środowiska specjalną zmienną o nazwie RETURN o wartości #f. +;; Jeśli w funkcji gdziekolwiek wywołam returna, to +;; zmieniam wartość RETURN w środowisku na to, co chcę zwrócić. +;; W eval-cmd za każdym razem sprawdzam jaka jest wartość RETURN. +;; Jeśli jest to #f, to pracuje jakby nigdy nic, a jeśli jest to coś innego, +;; to po prostu zwracam aktualne środowisko. +;; Zatem funkcja zwraca środowisko, w którym zmienna RETURN +;; ustawiona jest na wynik jej obliczenia. + +;; Teraz już prosto widać, że jedyne co robi call, to szuka ciała funkcji +;; w środowisku i wywołuje ją dla podanych argumentów, dostaje od tej +;; funkcji środowisko, a następnie odzyskuje wartość RETURN w zwróconym +;; przez nią środowisku. Dzięki temu po wywołaniu funkcji +;; wewnątrz innej funkcji nie zmienią się wartości żadnych zmiennych (w tym globalnych). +;; Jest to dosyć podobne do pythona -- tam inty są immutable i nie można ich wysłać przez +;; referencję. Ale możemy to robić jeśli się uprzemy np. tak: +;; {func decr (x) +;; (return (- x 1))} +;; {func main () +;; {(i := (call decr (i))) +;; (return i)} +;; Uruchomienie takiego programu ze zmienną globalną i zwróci oczywiście i-1. + +;; Mały problem którego za bardzo nie umiem rozwiązać jest taki, że jeśli gdzieś poza +;; jakąkolwiek funkcją wywołam return, to wartość którą tam zwrócę będzie +;; wartością dla całego programu, bo zmienna RETURN w środowisku zmieni swoją wartość +;; na coś innego od #f i niestety main nawet się nie wykona (na samym wstępie stwierdzi, +;; że coś zostało już zwrócone). Widać to w TEST10. Generalnie co za tym idzie, +;; między definicjami funkcji mogą być jakieś instrukcje, które zostaną +;; wywołane razem z ewaluacją programu, zanim zostanie wywołany main. + +;; Dodatkowe informacje umieściłem w komentarzach w odpowiednich miejscach pliku. +;; Na dole umieściłem kilka testów które pokazują co jak działa. + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) +(struct var-expr (name) #:transparent) +(struct call-expr (name args) #:transparent) ;; wywołanie funkcji + +(define (operator? x) + (member x '(+ * - / > < = >= <=))) + +(define (keyword? x) + (member x '(skip while if := func func-rec call return))) ;; kilka nowych słów kluczowych + +(define (expr? e) + (match e + [(const v) + (integer? v)] + [(var-expr x) + (and (symbol? x) + (not (keyword? x)))] + [(binop op l r) + (and (operator? op) + (expr? l) + (expr? r))] + [(call-expr n a) + (and (symbol? n) + (list? a) + (andmap expr? a))] + [_ false])) + +(struct skip () #:transparent) +(struct assign (id exp) #:transparent) +(struct if-cmd (exp ct cf) #:transparent) +(struct while (exp cmd) #:transparent) +(struct comp (left right) #:transparent) +(struct var-in (name expr cmd) #:transparent) +(struct function (name args cmd) #:transparent) ;; dodane funkcje, funkcje rekurencyjne oraz return +(struct funcrec (name args cmd) #:transparent) +(struct return-stat (exp) #:transparent) + +(define (cmd? c) + (match c + [(skip) true] + [(assign x e) (and (symbol? x) (expr? e))] + [(if-cmd e ct cf) (and (expr? e) (cmd? ct) (cmd? cf))] + [(while e c) (and (expr? e) (cmd? c))] + [(comp c1 c2) (and (cmd? c1) (cmd? c2))] + [(var-in x e c) (and (symbol? x) (expr? e) (cmd? c))] + [(function f a c) (and (symbol? f) (list? a) (andmap symbol? a) (cmd? c))] + [(funcrec f a c) (and (symbol? f) (list? a) (andmap symbol? a) (cmd? c))] + [(return-stat exp) (expr? exp)])) + +(define (prog? p) + (cmd? p)) + +(define (parse-expr p) + (cond + [(number? p) (const p)] + [(and (symbol? p) + (not (keyword? p))) + (var-expr p)] + [(and (list? p) + (= 3 (length p)) + (operator? (car p))) + (binop (first p) + (parse-expr (second p)) + (parse-expr (third p)))] + [(and (list? p) ; <------ wywołanie funkcji + (= (length p) 3) + (eq? (first p) 'call) + (symbol? (second p)) + (list? (third p))) + (call-expr (second p) (map parse-expr (third p)))] + [else false])) + +(define (parse-cmd q) + (cond + [(eq? q 'skip) (skip)] + [(and (list? q) + (= (length q) 3) + (eq? (second q) ':=)) + (assign (first q) (parse-expr (third q)))] + [(and (list? q) + (= (length q) 4) + (eq? (first q) 'if)) + (if-cmd (parse-expr (second q)) (parse-cmd (third q)) (parse-cmd (fourth q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'while)) + (while (parse-expr (second q)) (parse-cmd (third q)))] + [(and (list? q) + (= (length q) 3) + (eq? (first q) 'var) + (list? (second q)) + (= (length (second q)) 2)) + (var-in (first (second q)) + (parse-expr (second (second q))) + (parse-cmd (third q)))] + [(and (list? q) ; <------ funkcje + (= (length q) 4) + (eq? (first q) 'func) + (symbol? (second q)) + (list? (third q)) + (andmap symbol? (third q))) + (function (second q) (third q) (parse-cmd (fourth q)))] + [(and (list? q) ; <------ return + (= (length q) 2) + (eq? (first q) 'return)) + (return-stat (parse-expr (second q)))] + [(and (list? q) + (>= (length q) 2)) + (desugar-comp (map parse-cmd q))] + [else false])) + +(define (desugar-comp cs) + (if (null? (cdr cs)) + (car cs) + (comp (car cs) + (desugar-comp (cdr cs))))) + +(define (value? v) + (number? v)) + +(struct mem (xs) #:transparent) + +(define (mem-lookup x m) + (define (assoc-lookup xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cdar xs)] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (mem-xs m))) + +(define (mem-update x v m) + (define (assoc-update xs) + (cond + [(null? xs) (error "Undefined variable" x)] + [(eq? x (caar xs)) (cons (cons x v) (cdr xs))] + [else (cons (car xs) (assoc-update (cdr xs)))])) + (mem (assoc-update (mem-xs m)))) + +(define (mem-alloc x v m) + (mem (cons (cons x v) (mem-xs m)))) + +(define (mem-drop-last m) + (cond + [(null? (mem-xs m)) + (error "Deallocating from empty memory")] + [else + (mem (cdr (mem-xs m)))])) + +(define empty-mem + (mem null)) + +(define (op->proc op) + (match op + ['+ +] + ['- -] + ['* *] + ['/ /] + ['< (lambda (x y) (if (< x y) 1 0))] + ['> (lambda (x y) (if (> x y) 1 0))] + ['= (lambda (x y) (if (= x y) 1 0))] + ['<= (lambda (x y) (if (<= x y) 1 0))] + ['>= (lambda (x y) (if (>= x y) 1 0))] + )) + +;; zał: (expr? e) i (mem? m) jest prawdą +;; (value? (eval e m)) jest prawdą +(define (eval e m) + (match e + [(const v) v] + [(var-expr x) (mem-lookup x m)] + [(binop op l r) + (let ((vl (eval l m)) + (vr (eval r m)) + (p (op->proc op))) + (p vl vr))] + [(call-expr name args) ;; <------ ewaluacja wywołania funkcji + (match (mem-lookup name m) + [(clo func-args cmd) + (if (= (length args) (length func-args)) ;; <------ sprawdzanie arnosci + (let* ([func-mem (assign-values args func-args m)] + [final-mem (eval-cmd cmd func-mem)] + [ret (mem-lookup 'RETURN final-mem)]) + (if ret + ret + (error "No return statement in function" name))) + (error "Arity mismatch, function" name "takes" (length func-args) "arguments, got" (length args)))] + [else (error "Undefined function" name)])])) + +(define (assign-values args func-args mem) ;; <------ przypisanie wartosci do argumentow funkcji + (define (iter args func-args new-mem) + (if (null? args) + new-mem + (iter (cdr args) (cdr func-args) (mem-alloc (car func-args) (eval (car args) mem) new-mem)))) + (iter args func-args mem)) + + +(struct clo (args cmd)) ; <----- tak trzymana jest funkcja w środowisku, tj. jako lista nazw argumentow i cialo funkcji + +;; zał: (cmd? c) (mem? m) +;; (mem? (eval-cmd c m)) +(define (eval-cmd c m) + (if (mem-lookup 'RETURN m) ; <----- jeśli RETURN jest na coś ustawione, to chcemy zrwócic pamięc + m + (match c + [(skip) m] + [(assign x e) (mem-update x (eval e m) m)] + [(if-cmd e ct cf) (if (= (eval e m) 0) + (eval-cmd cf m) + (eval-cmd ct m))] + [(while e cw) (if (= (eval e m) 0) + m + (let* ((m1 (eval-cmd cw m)) + (m2 (eval-cmd c m1))) + m2))] + [(comp c1 c2) (let* ((m1 (eval-cmd c1 m)) + (m2 (eval-cmd c2 m1))) + m2)] + [(var-in x e c) (let* ((v (eval e m)) + (m1 (mem-alloc x v m)) + (m2 (eval-cmd c m1))) + (mem-drop-last m2))] + [(function name args cmd) ; <------ dodanie ciała funkcji do środowiska + (mem-alloc name (clo args cmd) m)] + [(return-stat val) ; <------ zmiana wartości zmiennej RETURN + (mem-update 'RETURN (eval val m) m)] + [_ (error "Unknown command" c "— likely a syntax error")]))) + + +;; program ewaluowany jest tak +;; ewaluowane są wszystkie definicje funkcji, wtedy +;; ręcznie szukam definicji main i ewaluuje jej ciało i zwracam to co zwróci main. +;; zakładam, że main nie przyjmuje żadnych argumentów. +(define (eval-prog p m) + (let ((final-mem (eval-cmd p (mem-alloc 'RETURN #f m)))) + (match (mem-lookup 'main final-mem) + [(clo args cmd) + (let ((res (mem-lookup 'RETURN (eval-cmd cmd final-mem)))) + (if res res (error "No return statement in main")))]))) + +(define WHILE_FACT + '({func decr (x) + {(x := (- x 1)) + (return x)}} + {func main () + {(i := 1) + (while (> t 0) + {(i := (* i t)) + (t := (call decr (t)))}) + (return i)}} + )) + +(define (fact n) + (let* ([init-env (mem-alloc 'i 1 (mem-alloc 't n empty-mem))]) + (eval-prog (parse-cmd WHILE_FACT) init-env))) + +(define TEST + '({func decr (x) (return (- x 1))} + {func main () + (var (x 1) + {(x := (+ x 2)) + (return (call decr (x)))})})) +(define (test) (eval-prog (parse-cmd TEST) empty-mem)) + +(define TEST2 + '({func decr (x) (return (- x 1))} + {func main () (return (call decr (3)))})) +(define (test2) (eval-prog (parse-cmd TEST2) empty-mem)) + +; nie da się zmienić wartości zmiennej globalnej, zmienne są wysyłane przez kopie +(define TEST3 + '({func sth (x) + {(i := -1) + (return x)}} + {func main () + {(i := 2) + (return (call sth (i)))}})) +(define (test3) (eval-prog (parse-cmd TEST3) (mem-alloc 'i 3 empty-mem))) + +; nie ma maina, wywala błąd +(define TEST4 + '(func f () + {return 1})) +(define (test4) (eval-prog (parse-cmd TEST4) empty-mem)) + +; funkcje wieloargumentowe +(define TEST5 + '({func f1 (x y z) + (return y)} + {func f2 (x y z) + (return (+ (+ x y) z))} + {func main () + {(if (> X 3) + (var (x 2) + (return (call f1 (1 x 3)))) + (x := 5)) + (return (call f2 (x 3 4)))}})) +(define (test5) (eval-prog (parse-cmd TEST5) (mem-alloc 'x -1 (mem-alloc 'X 4 empty-mem)))) + +; Działa rekurencja!! +(define TEST6 + '({func f (x) + (if (= x 0) + (return 1) + (return (* x (call f ((- x 1))))))} + {func main () + (return (call f (X)))})) +(define (test6) (eval-prog (parse-cmd TEST6) (mem-alloc 'X 5 empty-mem))) + +; kolejnośc deklaracji funkcji nie ma znaczenia, można zagnieżdżać funkcje +(define TEST7 + '( + {func main () + (return (call f (2)))} + {func f (x) + (return (call f1 (x)))} + {func f1 (x) + {{func local-fun (x) + (return (+ 1 x))} + (return (call local-fun (x)))}})) +(define (test7) (eval-prog (parse-cmd TEST7) empty-mem)) + +; instrukcje poza jakimikolwiek funkcjami sa wykonywane przed wywołaniem main +(define TEST8 + '({func main () + (return i)} + (i := 2))) +(define (test8) (eval-prog (parse-cmd TEST8) (mem-alloc 'i 1 empty-mem))) + +; nic nie zwraca main, wywala błąd +(define TEST9 + '(func main () + (i := 1))) +(define (test9) (eval-prog (parse-cmd TEST9) (mem-alloc 'i 1 empty-mem))) + +; return poza jakąkolwiek funkcją jest wynikiem programu +(define TEST10 + '({func main () + (return i)} + (i := 2) + (return -1))) +(define (test10) (eval-prog (parse-cmd TEST10) (mem-alloc 'i 1 empty-mem))) + + +; arity mismatch +(define TEST11 + '({func main () + (return (call decr ()))} + {func decr (x) + (return (- x 1))})) +(define (test11) (eval-prog (parse-cmd TEST11) empty-mem)) diff --git a/semestr-2/racket/egzamin/zad2.bak b/semestr-2/racket/egzamin/zad2.bak new file mode 100644 index 0000000..02e2ae0 --- /dev/null +++ b/semestr-2/racket/egzamin/zad2.bak @@ -0,0 +1,119 @@ +#lang racket + +;; ZADANIE 2 +;; ========= + +;; W tym zadaniu przyjrzymy się pierwszemu "językowi programowania" +;; który widzieliśmy na zajęciach: wyrażeniom arytmetycznym. Ich +;; prostota przejawia się przede wszystkim tym że nie występują w nich +;; zmienne (a w szczególności ich wiązanie) — dlatego możemy o nich +;; wnioskować nie używając narzędzi cięższych niż te poznane na +;; wykładzie. + +;; W tym zadaniu będziemy chcieli udowodnić że nasza prosta kompilacja +;; do odwrotnej notacji polskiej jest poprawna. Konkretniej, należy +;; · sformułować zasady indukcji dla obydwu typów danych +;; reprezentujących wyrażenia (expr? i rpn-expr?) +;; · sformułować i udowodnić twierdzenie mówiące że kompilacja +;; zachowuje wartość programu, tj. że obliczenie wartości programu +;; jest równoważne skompilowaniu go do RPN i obliczeniu. +;; · sformułować i udowodnić twierdzenie mówiące że translacja z RPN +;; do wyrażeń arytmetycznych (ta która była zadaniem domowym; +;; implementacja jest poniżej) jest (prawą) odwrotnością translacji +;; do RPN (czyli że jak zaczniemy od wyrażenia i przetłumaczymy do +;; RPN i z powrotem, to dostaniemy to samo wyrażenie). +;; Swoje rozwiązanie należy wpisać na końcu tego szablonu w +;; komentarzu, podobnie do niniejszej treści zadania; proszę zadbać o +;; czytelność dowodów! + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) + +(define (operator? x) + (member x '(+ * - /))) + +(define (expr? e) + (match e + [(const v) + (integer? v)] + [(binop op l r) + (and (operator? op) + (expr? l) + (expr? r))] + [_ false])) + + +(define (value? v) + (number? v)) + +(define (op->proc op) + (match op + ['+ +] + ['- -] + ['* *] + ['/ /])) + +;; zał: (expr? e) jest prawdą +;; (value? (eval e)) jest prawdą +(define (eval e) + (match e + [(const v) v] + [(binop op l r) + (let ((vl (eval l)) + (vr (eval r)) + (p (op->proc op))) + (p vl vr))])) + +(define (rpn-expr? e) + (and (list? e) + (pair? e) + (andmap (lambda (x) (or (number? x) (operator? x))) e))) + + +(struct stack (xs)) + +(define empty-stack (stack null)) +(define (empty-stack? s) (null? (stack-xs s))) +(define (top s) (car (stack-xs s))) +(define (push a s) (stack (cons a (stack-xs s)))) +(define (pop s) (stack (cdr (stack-xs s)))) + + +(define (eval-am e s) + (cond + [(null? e) (top s)] + [(number? (car e)) (eval-am (cdr e) (push (car e) s))] + [(operator? (car e)) + (let* ((vr (top s)) + (s (pop s)) + (vl (top s)) + (s (pop s)) + (v ((op->proc (car e)) vl vr))) + (eval-am (cdr e) (push v s)))])) + +(define (rpn-eval e) + (eval-am e empty-stack)) + +(define (arith->rpn e) + (match e + [(const v) (list v)] + [(binop op l r) (append (arith->rpn l) (arith->rpn r) (list op))])) + +(define (rpn-translate e s) + (cond + [(null? e) + (top s)] + + [(number? (car e)) + (rpn-translate (cdr e) (push (const (car e)) s))] + + [(operator? (car e)) + (let* ((er (top s)) + (s (pop s)) + (el (top s)) + (s (pop s)) + (en (binop (car e) el er))) + (rpn-translate (cdr e) (push en s)))])) + +(define (rpn->arith e) + (rpn-translate e empty-stack))
\ No newline at end of file diff --git a/semestr-2/racket/egzamin/zad2.rkt b/semestr-2/racket/egzamin/zad2.rkt new file mode 100644 index 0000000..e549f07 --- /dev/null +++ b/semestr-2/racket/egzamin/zad2.rkt @@ -0,0 +1,186 @@ +#lang racket + +;; Oświadczam, że rozwiązanie zadania egzaminacyjnego przygotowałem +;; w pełni samodzielnie, korzystając wyłącznie z materiałów do wykładu, +;; notatek, podręcznika, oraz materiałów zacytowanych w treści rozwiązania. +;; Oświadczam że nie korzystałem w żadnej formie z pomocy osób trzecich +;; w przygotowaniu rozwiązania ani też takiej pomocy nie udzielałem +;; i nie udostępniałem nikomu swojego rozwiązania. + +;; ZADANIE 2 +;; ========= + +;; W tym zadaniu przyjrzymy się pierwszemu "językowi programowania" +;; który widzieliśmy na zajęciach: wyrażeniom arytmetycznym. Ich +;; prostota przejawia się przede wszystkim tym że nie występują w nich +;; zmienne (a w szczególności ich wiązanie) — dlatego możemy o nich +;; wnioskować nie używając narzędzi cięższych niż te poznane na +;; wykładzie. + +;; W tym zadaniu będziemy chcieli udowodnić że nasza prosta kompilacja +;; do odwrotnej notacji polskiej jest poprawna. Konkretniej, należy +;; · sformułować zasady indukcji dla obydwu typów danych +;; reprezentujących wyrażenia (expr? i rpn-expr?) +;; · sformułować i udowodnić twierdzenie mówiące że kompilacja +;; zachowuje wartość programu, tj. że obliczenie wartości programu +;; jest równoważne skompilowaniu go do RPN i obliczeniu. +;; · sformułować i udowodnić twierdzenie mówiące że translacja z RPN +;; do wyrażeń arytmetycznych (ta która była zadaniem domowym; +;; implementacja jest poniżej) jest (prawą) odwrotnością translacji +;; do RPN (czyli że jak zaczniemy od wyrażenia i przetłumaczymy do +;; RPN i z powrotem, to dostaniemy to samo wyrażenie). +;; Swoje rozwiązanie należy wpisać na końcu tego szablonu w +;; komentarzu, podobnie do niniejszej treści zadania; proszę zadbać o +;; czytelność dowodów! + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) + +(define (operator? x) + (member x '(+ * - /))) + +(define (expr? e) + (match e + [(const v) + (integer? v)] + [(binop op l r) + (and (operator? op) + (expr? l) + (expr? r))] + [_ false])) + + +(define (value? v) + (number? v)) + +(define (op->proc op) + (match op + ['+ +] + ['- -] + ['* *] + ['/ /])) + +;; zał: (expr? e) jest prawdą +;; (value? (eval e)) jest prawdą +(define (eval e) + (match e + [(const v) v] + [(binop op l r) + (let ((vl (eval l)) + (vr (eval r)) + (p (op->proc op))) + (p vl vr))])) + +(define (rpn-expr? e) + (and (list? e) + (pair? e) + (andmap (lambda (x) (or (number? x) (operator? x))) e))) + +;; mój kod +(define (parse-expr q) + (cond + [(integer? q) (const q)] + [(and (list? q) (= (length q) 3) (operator? (first q))) + (binop (first q) (parse-expr (second q)) (parse-expr (third q)))])) + +(struct stack (xs)) + +(define empty-stack (stack null)) +(define (empty-stack? s) (null? (stack-xs s))) +(define (top s) (car (stack-xs s))) +(define (push a s) (stack (cons a (stack-xs s)))) +(define (pop s) (stack (cdr (stack-xs s)))) + + +(define (eval-am e s) + (cond + [(null? e) (top s)] + [(number? (car e)) (eval-am (cdr e) (push (car e) s))] + [(operator? (car e)) + (let* ((vr (top s)) + (s (pop s)) + (vl (top s)) + (s (pop s)) + (v ((op->proc (car e)) vl vr))) + (eval-am (cdr e) (push v s)))])) + +(define (rpn-eval e) + (eval-am e empty-stack)) + +(define (arith->rpn e) + (match e + [(const v) (list v)] + [(binop op l r) (append (arith->rpn l) (arith->rpn r) (list op))])) + +(define (rpn-translate e s) + (cond + [(null? e) + (top s)] + + [(number? (car e)) + (rpn-translate (cdr e) (push (const (car e)) s))] + + [(operator? (car e)) + (let* ((er (top s)) + (s (pop s)) + (el (top s)) + (s (pop s)) + (en (binop (car e) el er))) + (rpn-translate (cdr e) (push en s)))])) + +(define (rpn->arith e) + (rpn-translate e empty-stack)) + + +;; W kilku miejscach pozwoliłem sobie zapomnieć że symbol operatora i operator +;; to nie to samo, ale nie ma to znaczenia w kontekście dowodów. +;; Przez ES oznaczam empty-stack +;; +;; Zasada indukcji dla expr: +;; Dla dowolnej własności P, jeśli +;; · zachodzi P((const x)) dla dowolnego x oraz +;; · dla dowolnych e1, e2 oraz operator op jeśli zachodzi P(e1), P(e2) +;; to zachodzi P((binop op e1 e2)) +;; to dla dowolnego e, jeśli zachodzi (expr? e) to zachodzi P(e) +;; +;; Zasada indukcji dla rpn (ale tego wg rpn-expr?): +;; Dla dowolnej własności P, jeśli +;; · zachodzi P(x) dla dowolnej liczby lub opeartora x oraz +;; · dla dowolnej listy liczb lub operatorów xs oraz dowolnej liczby lub +;; operatora x, jesli zachodzi P(xs), to zachodzi P((cons x xs)) +;; to dla dowolnej listy xs liczb lub operatorów zachodzi P(xs) +;; +;; +;; Tw. 1: Jeśli spełnione jest (expr? e), to (eval e) ≡ (rpn-eval (arith->rpn e)) +;; +;; D-d. Skorzystamy z zasady indukcji dla wyrażeń. +;; · Weźmy dowolną liczbę x. Wtedy jeśli e ≡ (const x), to zachodzi +;; (eval (const x)) ≡ x ≡ (rpn-eval '(x)) ≡ (rpn-eval (arith->rpn (const x))) +;; · Weźmy dowolne e1, e2 spełniające naszą tezę oraz jakiś operator op. Wtedy +;; (eval (binop op e1 e2)) ≡ +;; (op (eval e1) (eval e2)) ≡ [Z definicji eval-am] +;; (eval-am '() (push (op (eval e1) (eval e2)) ES)) ≡ +;; (eval-am '(op) (push (eval e2) (push (eval e1) ES))) ≡ [Z założenia indukcyjnego] +;; (eval-am '(op) (push (rpn-eval (arith->rpn e2)) (push (eval e1) ES))) ≡ +;; (eval-am (append (arith->rpn e2) '(op)) (push (eval e1) ES)) ≡ [Z założenia indukcyjnego] +;; (eval-am (append (arith->rpn e1) (arith->rpn e2) '(op)) ES) ≡ +;; (rpn-eval (append (arith->rpn e1) (arith->rpn e2) '(op))) ≡ [Z definicji arith->rpn] +;; (rpn-eval (arith->rpn (binop op e1 e2))) +;; Pokazaliśmy oba warunki indukcji dla wyrażeń, zatem twierdzenie prawdziwe jest +;; dla dowolnego wyrażenia e spełniającego (expr? e). +;; +;; Tw. 2: Jeśli spełnione jest (expr? e), to (rpn->arith (arith->rpn e)) ≡ e +;; +;; D-d. Skoryzstamy z indukcji dla wyrażeń. +;; · Weźmy dowolną liczbę x. Wtedy dla e ≡ (const x) zachodzi +;; (rpn->arith (arith->rpn e)) ≡ (rpn->arith '(x)) ≡ (const x) +;; · Weźmy dowolne e1, e2 dla których twierdzenie zachodzi oraz operator op. Wtedy +;; (rpn->arith (arith->rpn (binop op e1 e2))) ≡ [Z definicji arith->rpn] +;; (rpn->arith (append (arith->rpn e1) (arith->rpn e2) '(op))) ≡ +;; (rpn-translate (append (arith->rpn e1) (arith->rpn e2) '(op)) ES) ≡ [Z zał. (arith->rpn e1) ewaluuje się do liczby] +;; (rpn-translate (append (arith->rpn e2) '(op)) (push e1 ES)) ≡ [Z zał. (arith->rpn e2) ewaluuje się do liczby] +;; (rpn-translate '(op) (push e2 (push e1 ES))) ≡ [Z definicji rpn-translate] +;; (rpn-translate '() (push (binop op e1 e2) ES)) ≡ +;; (binop op e1 e2) +;; Pokazaliśmy oba warunki indukcji dla wyrażeń, zatem twierdzenie jest prawdziwe +;; dla dowolnego e spełniającego (expr? e). diff --git a/semestr-2/racket/egzamin/zad3.bak b/semestr-2/racket/egzamin/zad3.bak new file mode 100644 index 0000000..20115e9 --- /dev/null +++ b/semestr-2/racket/egzamin/zad3.bak @@ -0,0 +1,4 @@ +#lang racket + + + diff --git a/semestr-2/racket/egzamin/zad3.rkt b/semestr-2/racket/egzamin/zad3.rkt new file mode 100644 index 0000000..9bfed02 --- /dev/null +++ b/semestr-2/racket/egzamin/zad3.rkt @@ -0,0 +1,347 @@ +#lang racket + +;; Oświadczam, że rozwiązanie zadania egzaminacyjnego przygotowałem +;; w pełni samodzielnie, korzystając wyłącznie z materiałów do wykładu, +;; notatek, podręcznika, oraz materiałów zacytowanych w treści rozwiązania. +;; Oświadczam że nie korzystałem w żadnej formie z pomocy osób trzecich +;; w przygotowaniu rozwiązania ani też takiej pomocy nie udzielałem +;; i nie udostępniałem nikomu swojego rozwiązania. + +;; ZADANIE 3 +;; ========= + +;; Z gramatykami bezkontekstowymi spotkaliście się już na Wstępie do +;; Informatyki. W tym zadaniu potraktujemy je jako dane dla naszych +;; programów. + +;; Przypomnijmy, że gramatyka bezkontekstowa składa się z +;; · skończonego zbioru *symboli nieterminalnych* +;; · skończonego zbioru *symboli terminalnych* +;; · wybranego nieterminalnego symbolu startowego +;; · zbioru *produkcji*, czyli par symbol nieterminalny - lista +;; (potencjalnie pusta) symboli terminalnych lub nieterminalnych + +;; Słowo (ciąg symboli terminalnych) możemy wyprowadzić z gramatyki, +;; jeśli możemy zacząć od ciągu składającego się z symbolu startowego +;; możemy użyć skończonej liczby produkcji z gramatyki przepisując +;; symbol nieterminalny na ciąg symboli mu odpowiadających (w danej +;; produkcji). + + +;; Przykład: poprawne nawiasowania + +;; Gramatyka składa się z jednego symbolu nieterminalnego, S (który +;; jest oczywiście symbolem startowym) i dwóch symboli terminalnych +;; "(" i ")", i zawiera następujące produkcje (zwyczajowo zapisywane +;; przy użyciu strzałki; zwróćcie uwagę że pierwszy ciąg jest pusty!): +;; S -> +;; S -> SS +;; S -> (S) + +;; W często spotykanej, bardziej zwięzłej, postaci BNF moglibyśmy tę +;; gramatykę zapisać tak (dbając trochę bardziej o wizualne +;; oddzielenie symboli terminalnych i nieterminalnych): +;; S ::= "" | SS | "(" S ")" +;; Mamy tu te same produkcje, ale tylko raz zapisujemy każdą z +;; powtarzających się lewych stron. + +;; Z gramatyki tej da się wyprowadzić wszystkie poprawnie rozstawione +;; ciągi nawiasów — zobaczmy jak wyprowadzić (na jeden ze sposobów) +;; ciąg "(()())". Zaczynamy, jak zawsze, od słowa złożonego z symbolu +;; startowego i przepisujemy: +;; S -> (S) -> (SS) -> ((S)S) -> ((S)(S)) -> (()(S)) -> (()()) + + +;; Zadanie cz. 1 + +;; Zdefiniuj reprezentację gramatyki jako typu danych w +;; Rackecie. Warto zastanowić się co można uprościć względem definicji +;; matematycznej — w szczególności możemy założyć że dowolne napisy +;; (typu string) są ciągami symboli terminalnych, i że nie musimy +;; podawać jawnie zbioru nieterminali; również reprezentacja produkcji +;; gramatyki jako worka z parami wejście-wyjście niekoniecznie jest +;; najwygodniejsza. + +;; Uwaga: w tym zadaniu nie wymagamy definiowania składni konkretnej i +;; parsowania, ale bardzo polecamy wybranie jakiejś formy, żeby móc +;; sensownie przetestować swoje rozwiązanie! + + +;; "Optymalizacja" gramatyk + +;; Gramatyki, podobnie jak programy, piszą ludzie — może więc zdarzyć +;; się że znajdą się tam śmieci. Mogą one mieć dwojaką formę: symboli +;; nieterminalnych, których nie da się wyprowadzić z symbolu +;; startowego, lub symboli nieterminalnych z których nie da się +;; wyprowadzić żadnego słowa terminalnego (tj. niezawierającego +;; symboli nieterminalnych). Przykładowo, do naszej gramatyki +;; moglibyśmy dodać symbole P i Q, i produkcje: +;; S -> ")(" P +;; P -> PP "qed" +;; Q -> "abc" + +;; Mimo że nasza gramatyka wygląda inaczej na pierwszy rzut oka, tak +;; naprawdę się nie zmieniła: do symbolu Q nie możemy dojść z symbolu +;; S, a więc "abc" nigdy nie wystąpi w słowie wyprowadzalnym z +;; gramatyki. Analogicznie, z P nie da się wyprowadzić żadnego słowa, +;; które nie zawierałoby symbolu P — a zatem żadnego słowa złożonego +;; tylko z symboli terminalnych. To znaczy, że naszą gramatykę możemy +;; uprościć wyrzucając z niej symbole nieterminalne (i produkcje które +;; ich używają) do których nie da się dojść (tj. są *nieosiągalne*) i +;; te, z których nie da się ułożyć słowa terminalnego (tj. są +;; *nieproduktywne*). Jeśli z naszej rozszerzonej gramatyki wyrzucimy +;; takie symbole, dostaniemy oczywiście gramatykę początkową. + + +;; Zadanie cz. 2 + +;; Dla swojej reprezentacji gramatyki z poprzedniej części zadania +;; napisz dwie procedury: cfg-unreachable, znajdującą symbole +;; nieterminalne które są nieosiągalne z symbolu startowego, i +;; cfg-unproductive, znajdującą symbole nieterminalne które nie są +;; produktywne. Następnie użyj tych procedur żeby zdefiniować +;; procedurę cfg-optimize, która uprości daną gramatykę usuwając z +;; niej symbole nieosiągalne i nieproduktywne, a także odpowiednie +;; produkcje. + +;; Rozwiązanie wpisz w poniższym pliku, i opatrz komentarzem +;; opisującym wybraną reprezentację (i podjęte przy jej projektowaniu +;; decyzje), a także zaimplementowane w cz. 2. algorytmy. + + + + + + +;; Zadanie 1 + +;; Reprezentacja jest docyś prosta, mianowicie stworzyłem struktury +;; terminal, non-terminal, rule oraz grammar. Dwa pierwsze to +;; po prostu jednoelementowe struktury utrzymujące nazwę symboli. +;; grammar to dwuelementowa struktura, jej pierwszym elementem +;; jest symbol startowy, a następnym produkcja, czyli lista reguł (listof rule), +;; a reguły to dwuelementowe struktury (symbol niterminalny - lista nonterminali lub termianli). +;; Generalnie dzięki temu, że mam te struktury terminal oraz non-terminal +;; to symbol nieterminalne i temrinalne mogą być czykolwiek. Dodatkowo +;; dla uproszczenia w miejscach, gdzie mam pewność że chodzi mi o +;; symbol nieterminalny, to nie opakowuję go w strukturę. +;; Przykładowo rules w gramatyce może wyglądać tak: +;; (list +;; (rule 'S (list (terminal ""))) +;; (rule 'S (list (non-terminal 'S) (non-terminal 'S))) +;; (rule 'S (list (terminal "(") (non-terminal 'S) (terminal ")")))) +;; Oczywiście symbol nieterminalny nie musi być racketowym symbolem, może być czymkolwiek. +;; Podobnie z symbolami terminalnymi. Proszę również zauważyć, że dzięki +;; strukturom non-terminal oraz terminal te same racketowe obiekty mogą być jednocześnie +;; terminalami oraz nieterminalami! +;; W tych parach na pierwszym miejscu nie jest non-terminal, tylko po prostu cokolwiek +;; no i oczywiście mam wtedy pewność że musi być to non-terminal, nie ma potrzeby +;; żeby pakować go również w tę strukturę. + + +;; Postanowiłem napisać parser (make-cfg q), generuje on gramatyki w bardzo konkretny sposób, +;; trochę ograniczo to czym mogą być symbole nieterminalne oraz terminalne, +;; ale nie wydaje mi się że i tak składnia jest bardzo wygodna i mało ograniczająca. + +;; Składnia konkretna naszych gramatyk wygląda bardzo podobnie do zapisu +;; przedstawionego w treści zadania. +;; np. gramatyka nawiasowania będzie wyglądać następująco: +;; '(grammar S (S ::= "" -- SS -- "(" S ")")) +;; ale mogłaby wyglądać też tak: +;; '(grammar S (S ::= "") (S ::= SS -- "(" S ")")) +;; a np. ta nieciekawa gramatyka przedstawiona w treści zadania: +;; '(grammar S (S ::= "] [" P) (P ::= PP "qed") (Q ::= "abc")) +;; Zatem będzie to lista, która na pierwszym miejscu ma symbol 'grammar +;; na drugim miejscu ma symbol startowy +;; następnie następuje lista produkcji w formacie: +;; <non-terminal> ::= <lista produkcji, produkcje oddzielone są separatorem --> +;; Zalety: +;; - rozróżnienie w składni konkretnej symboli nieterminalnych i terminalnych +;; przez użycie symboli i stringów pozwala na to, aby symbole terminalne nazywały się tak +;; jak terminalne, tj. "S" nie jest tym samym co 'S. +;; - składnia wydaje się bardzo wygodna w użyciu, nie ma też problemu, żeby później dopisać +;; dodatkowe reguły dla jakiegoś nieterminala, +;; - parser jest całkiem łatwy w implementacji +;; Wady: +;; - symbole nieterminalne mogą składać się jedynie z jednego symbolu, zatem nie możemy robić ich +;; zbyt wiele. Jest tak dlatego, że np. tutaj (S ::= SS) nie chodzi mi o symbol SS, tylko +;; o sąsiadujące symbole SS (jednak gdyby nie używać parsera to normalnie moglibyśmy +;; mieć wieloznakowe symbole nieterminalne!). + +;; Dla przykładu taka gramatyka: +;; '(grammar S (S ::= "" -- SS -- "(" S ")" -- Q) (Q ::= "" -- QS -- "[" Q "]")) +;; będzie reprezentowana następująco: +;; (grammar +;; 'S +;; (list +;; (rule 'S (list (terminal ""))) +;; (rule 'S (list (non-terminal 'S) (non-terminal 'S))) +;; (rule 'S (list (terminal "(") (non-terminal 'S) (terminal ")"))) +;; (rule 'S (list (non-terminal 'Q))) +;; (rule 'Q (list (terminal ""))) +;; (rule 'Q (list (non-terminal 'Q) (non-terminal 'S))) +;; (rule 'Q (list (terminal "[") (non-terminal 'Q) (terminal "]"))))) + +;; Cała reprezentacja :D +(struct non-terminal (sym) #:transparent) +(struct terminal (sym) #:transparent) +(struct rule (nt xs) #:transparent) +(struct grammar (start rules) #:transparent) + + +;; PARSER +(define SEPARATOR '--) + +(define (split-at-symb symb xs) + (define (iter left right) + (cond + [(null? right) (cons left null)] + [(eq? symb (car right)) (cons left (cdr right))] + [else (iter (cons (car right) left) (cdr right))])) + (let ([res (iter null xs)]) + (cons (reverse (car res)) (cdr res)))) + +(define (split-by-separator xs) + (let ([res (split-at-symb SEPARATOR xs)]) + (if (null? (cdr res)) + res + (cons (car res) (split-by-separator (cdr res)))))) + +;; PARSER SKŁADNI KONKRETNEJ DO JEJ REPREZENTACJI +(define (make-cfg q) + (cond + [(and (list? q) (eq? 'grammar (first q))) + (grammar (second q) (append-map make-cfg (cddr q)))] + [(and (list? q) (eq? '::= (second q))) + (let ([nt (first q)] + [rules (split-by-separator (cddr q))]) + (map (lambda (x) (rule nt x)) (map make-prod rules)))])) + +(define (symbol->list s) + (map string->symbol + (map string + (string->list (symbol->string s))))) + +(define (make-prod xs) + (cond + [(null? xs) null] + [(string? (car xs)) (cons (terminal (car xs)) (make-prod (cdr xs)))] + [(symbol? (car xs)) (append (map non-terminal (symbol->list (car xs))) (make-prod (cdr xs)))] + [else (error "Invalid syntax in production" xs)])) + + +(define sample '(S ::= "" -- SS -- "(" S ")")) +(define sample2 '(grammar S (S ::= "" -- SS -- "(" S ")" -- Q) (Q ::= "" -- QQ -- "[" Q "]"))) +(define sample3 '(grammar S + (S ::= A B -- D E) + (A ::= "a") + (B ::= "b" C) + (C ::= "c") + (D ::= "d" F) + (E ::= "e") + (F ::= "f" D))) + +(define (sample-grammar) (make-cfg sample3)) + +;; zadanie 2 + +;; korzystam z algorytmów przedstawionych w tej książce: +;; https://bit.ly/3ev0NUA, konkretnie te ze stron 50-51 +;; Pozwoliłem sobie trochę zmienić przeznaczenie funkcji cfg-unreachable oraz cfg-unproductive +;; Zamiast zwracać nieproduktywne nieterminale, zwracają właśnie produktywne +;; i analogicznie w tym drugim. Po prostu taka implementacja jest dla mnie wygodniejsza, +;; a jest bardzo nieistotną zmianą koncepcyjną. +;; Stąd zmiana nazwy na cfg-productive oraz cfg-reachable + +;; cfg-productive działa w ten sposób: +;; Jakiś nieterminal nazywamy produktywnym, jeśli ma co najmniej jedną produktywną zasadę +;; Jakąś regułę nazywamy produktywną, jeśli składa się z terminali lub produktywnych nieterminali +;; Jasno widać, że wg tej definicji te nieterminale, które nie są produktywne, są nieproduktywne +;; wg definicji zadania, a cała reszta jest produktwna. + +;; Algorytm znajdowania produktywnych nieterminali: +;; Mamy listę produktywnych nieterminali P, początkowo pustą +;; 1. Stwórz nową listę P' +;; 2. Przejdź po liście reguł +;; -> jeśli dana reguła jest produktywna (wg P), dodaj jej nieterminal do P' +;; 3. Jeśli P != P', zrób P := P' i wróć do 1. +;; 4. Zwróć P + +;; Fajne w tym algorytmie jest to, że jeśli mamy jakiś nieterminal, którego +;; używamy w jakiejś regule, ale ten nieterminal nie ma zdefiniowanej żadnej reguły, +;; to nie zostanie oznaczony jako produktywny, co jest dla nas korzystne. + +;; Algorytm znajdowania osiągalnych nieterminali: +;; Traktujemy nitereminale jak wierzchołki w grafie a reguły jako listy sąsiedztwa. +;; Terminale są liśćmi, a nieterminale węzłami. Robimy po prostu DFSa z nieterminala +;; startowego i węzły do których dotrzemy oznaczamy jako osiągalne. + +;; Wg papierka który tutaj podałem, jeśli najpierw usuniemy nieproduktywne nieterminale, +;; a w następnej kolejności nieosiągalne, to nasza gramatyka stanie się regularna. +;; Wydaje się to w miarę sensowne -- pierszy algorytm to takie odcinanie liści i odcyklanie +;; grafu, a ten drugi to po prostu DFS. + +;; przydatne predykaty -- na productive-nt mam listę symboli niterminalnych +;; (nie struktury non-terminal, tylko te symbole!) +;; które wiem że są produktywne. +;; productive? sprawdza, czy nietermial jest produktywny +;; to drugie sprawdza czy reguła jest produktywna +;; (czyli czy składa się z produktywnych nonterminali lub terminali) +(define (productive? p productive-nt) + (or (terminal? p) (member (non-terminal-sym p) productive-nt))) +(define (rule-productive? r productive-nt) + (andmap (lambda (x) (productive? x productive-nt)) r)) + +;; zwraca listę produktywnych symboli (nie nonterminali!) +(define (cfg-productive g) + (define (find-productive-nt productive-nt rules) + (cond + [(null? rules) (remove-duplicates productive-nt)] + [(rule-productive? (rule-xs (car rules)) productive-nt) + (find-productive-nt (cons (rule-nt (car rules)) productive-nt) (cdr rules))] + [else (find-productive-nt productive-nt (cdr rules))])) + (define (iter productive-nt) + (let ([new-prod-nt (find-productive-nt productive-nt (grammar-rules g))]) + (if (equal? productive-nt new-prod-nt) + productive-nt + (iter new-prod-nt)))) + (iter null)) + +;; zwraca listę osiągalnych symboli +(define (cfg-reachable g) + (define (iter verts vis) + (cond + [(null? verts) vis] + [(member (car verts) vis) (iter (cdr verts) vis)] + [else (iter (cdr verts) (dfs (car verts) vis))])) + (define (dfs v vis) + (let* ([rules (filter (lambda (r) (eq? (rule-nt r) v)) (grammar-rules g))] + [verts (append-map (lambda (r) (rule-xs r)) rules)] + [verts (filter non-terminal? verts)] + [verts (map non-terminal-sym verts)]) + (iter verts (cons v vis)))) + (dfs (grammar-start g) null)) + + +;; robi z gramatyki g gramatykę regularną +(define (cfg-optimize g) + (let* ([productive-nt (cfg-productive g)] + [productive-rules (filter (lambda (r) + (rule-productive? (rule-xs r) productive-nt)) + (grammar-rules g))] + [new-g (grammar (grammar-start g) productive-rules)] ; <----- nowa gramatyka, bez nieproduktywnych + [reachable-nt (cfg-reachable new-g)] ; reguł i symboli nieterminalnych + [res-g (grammar (grammar-start new-g) (filter ; <----- dobra gramatyka + (lambda (r) (member (rule-nt r) reachable-nt)) + (grammar-rules new-g)))]) + res-g)) + +(define (test) (cfg-optimize (make-cfg sample3))) + +;; Pokazanie że symbole nie muszą być racketowymi symbolami :) +(define (test2) (cfg-optimize + (grammar '() + (list (cons '() (list (terminal '()))) + (cons '() (list (terminal "(") (non-terminal '()) (terminal ")"))) + (cons '() (list (non-terminal '()) (non-terminal '()))))))) +
\ No newline at end of file diff --git a/semestr-2/racket/egzamin/zad3a.bak b/semestr-2/racket/egzamin/zad3a.bak new file mode 100644 index 0000000..81570d0 --- /dev/null +++ b/semestr-2/racket/egzamin/zad3a.bak @@ -0,0 +1,298 @@ +#lang racket + +;; ZADANIE 3 +;; ========= + +;; Z gramatykami bezkontekstowymi spotkaliście się już na Wstępie do +;; Informatyki. W tym zadaniu potraktujemy je jako dane dla naszych +;; programów. + +;; Przypomnijmy, że gramatyka bezkontekstowa składa się z +;; · skończonego zbioru *symboli nieterminalnych* +;; · skończonego zbioru *symboli terminalnych* +;; · wybranego nieterminalnego symbolu startowego +;; · zbioru *produkcji*, czyli par symbol nieterminalny - lista +;; (potencjalnie pusta) symboli terminalnych lub nieterminalnych + +;; Słowo (ciąg symboli terminalnych) możemy wyprowadzić z gramatyki, +;; jeśli możemy zacząć od ciągu składającego się z symbolu startowego +;; możemy użyć skończonej liczby produkcji z gramatyki przepisując +;; symbol nieterminalny na ciąg symboli mu odpowiadających (w danej +;; produkcji). + + +;; Przykład: poprawne nawiasowania + +;; Gramatyka składa się z jednego symbolu nieterminalnego, S (który +;; jest oczywiście symbolem startowym) i dwóch symboli terminalnych +;; "(" i ")", i zawiera następujące produkcje (zwyczajowo zapisywane +;; przy użyciu strzałki; zwróćcie uwagę że pierwszy ciąg jest pusty!): +;; S -> +;; S -> SS +;; S -> (S) + +;; W często spotykanej, bardziej zwięzłej, postaci BNF moglibyśmy tę +;; gramatykę zapisać tak (dbając trochę bardziej o wizualne +;; oddzielenie symboli terminalnych i nieterminalnych): +;; S ::= "" | SS | "(" S ")" +;; Mamy tu te same produkcje, ale tylko raz zapisujemy każdą z +;; powtarzających się lewych stron. + +;; Z gramatyki tej da się wyprowadzić wszystkie poprawnie rozstawione +;; ciągi nawiasów — zobaczmy jak wyprowadzić (na jeden ze sposobów) +;; ciąg "(()())". Zaczynamy, jak zawsze, od słowa złożonego z symbolu +;; startowego i przepisujemy: +;; S -> (S) -> (SS) -> ((S)S) -> ((S)(S)) -> (()(S)) -> (()()) + + +;; Zadanie cz. 1 + +;; Zdefiniuj reprezentację gramatyki jako typu danych w +;; Rackecie. Warto zastanowić się co można uprościć względem definicji +;; matematycznej — w szczególności możemy założyć że dowolne napisy +;; (typu string) są ciągami symboli terminalnych, i że nie musimy +;; podawać jawnie zbioru nieterminali; również reprezentacja produkcji +;; gramatyki jako worka z parami wejście-wyjście niekoniecznie jest +;; najwygodniejsza. + +;; Uwaga: w tym zadaniu nie wymagamy definiowania składni konkretnej i +;; parsowania, ale bardzo polecamy wybranie jakiejś formy, żeby móc +;; sensownie przetestować swoje rozwiązanie! + + +;; "Optymalizacja" gramatyk + +;; Gramatyki, podobnie jak programy, piszą ludzie — może więc zdarzyć +;; się że znajdą się tam śmieci. Mogą one mieć dwojaką formę: symboli +;; nieterminalnych, których nie da się wyprowadzić z symbolu +;; startowego, lub symboli nieterminalnych z których nie da się +;; wyprowadzić żadnego słowa terminalnego (tj. niezawierającego +;; symboli nieterminalnych). Przykładowo, do naszej gramatyki +;; moglibyśmy dodać symbole P i Q, i produkcje: +;; S -> ")(" P +;; P -> PP "qed" +;; Q -> "abc" + +;; Mimo że nasza gramatyka wygląda inaczej na pierwszy rzut oka, tak +;; naprawdę się nie zmieniła: do symbolu Q nie możemy dojść z symbolu +;; S, a więc "abc" nigdy nie wystąpi w słowie wyprowadzalnym z +;; gramatyki. Analogicznie, z P nie da się wyprowadzić żadnego słowa, +;; które nie zawierałoby symbolu P — a zatem żadnego słowa złożonego +;; tylko z symboli terminalnych. To znaczy, że naszą gramatykę możemy +;; uprościć wyrzucając z niej symbole nieterminalne (i produkcje które +;; ich używają) do których nie da się dojść (tj. są *nieosiągalne*) i +;; te, z których nie da się ułożyć słowa terminalnego (tj. są +;; *nieproduktywne*). Jeśli z naszej rozszerzonej gramatyki wyrzucimy +;; takie symbole, dostaniemy oczywiście gramatykę początkową. + + +;; Zadanie cz. 2 + +;; Dla swojej reprezentacji gramatyki z poprzedniej części zadania +;; napisz dwie procedury: cfg-unreachable, znajdującą symbole +;; nieterminalne które są nieosiągalne z symbolu startowego, i +;; cfg-unproductive, znajdującą symbole nieterminalne które nie są +;; produktywne. Następnie użyj tych procedur żeby zdefiniować +;; procedurę cfg-optimize, która uprości daną gramatykę usuwając z +;; niej symbole nieosiągalne i nieproduktywne, a także odpowiednie +;; produkcje. + +;; Rozwiązanie wpisz w poniższym pliku, i opatrz komentarzem +;; opisującym wybraną reprezentację (i podjęte przy jej projektowaniu +;; decyzje), a także zaimplementowane w cz. 2. algorytmy. + + + + + + +;; Zadanie 1 + +;; Postanowiłem napisać parser, bo bez tego zadanie wydaje mi się dosyć ubogie +;; Składnia konkretna naszych gramatyk wygląda bardzo podobnie do zapisu +;; przedstawionego w treści zadania. +;; np. gramatyka nawiasowania będzie wyglądać następująco: +;; '(grammar S (S ::= "" -- SS -- "(" S ")")) +;; ale mogłaby wyglądać też tak: +;; '(grammar S (S ::= "") (S ::= SS -- "(" S ")")) +;; a np. ta nieciekawa gramatyka przedstawiona w treści zadania: +;; '(grammar S (S ::= "] [" P) (P ::= PP "qed") (Q ::= "abc")) +;; Zatem będzie to lista, która na pierwszym miejscu ma symbol 'grammar +;; na drugim miejscu ma symbol startowy +;; następnie następuje lista produkcji w formacie: +;; <non-terminal> ::= <lista produkcji, produkcje oddzielone są separatorem --> +;; Zalety: +;; - rozróżnienie w składni konkretnej symboli nieterminalnych i terminalnych +;; przez użycie symboli i stringów pozwala na to, aby symbole terminalne nazywały się tak +;; jak terminalne, tj. "S" nie jest tym samym co 'S. +;; - składnia wydaje się bardzo wygodna w użyciu, nie ma też problemu, żeby później dopisać +;; dodatkowe produkcje dla jednego symbolu nieterminalnego, np. (S ::= "") (S ::= SS) +;; - parser jest łatwy w implementacji +;; Wady: +;; - symbole nieterminalne mogą składać się jedynie z jednego symbolu, zatem nie możemy robić ich +;; zbyt wiele + +;; Reprezentacja gramatyki: podczas parsowania gramatyki symbole i stringi wewnątrz produkcji +;; reprezentowane są przez struktury terminal oraz non-terminal. Cała gramatyka to +;; struktura dwuelementowa - pierwszym jest symbol startowy, a drugim lista par <symbol . produkcja> +;; Taka decyzja właśnie pozwoliła na to, że zaproponowana przeze mnie składania konkretna jest +;; bardzo prosta do sparsowania - wystarczy każdą produkcję podzielić ze względu na separator '-- +;; i do czegoś podobnego do środowisk dodawać po prostu odpowiednie pary. +;; dla przykładu taka gramatyka: +;; '(grammar S (S ::= "" -- SS -- "(" S ")" -- Q) (Q ::= "" -- QS -- "[" Q "]")) +;; będzie reprezentowana następująco: +;; (grammar +;; 'S +;; (production +;; (list +;; (list 'S (terminal "")) +;; (list 'S (non-terminal 'S) (non-terminal 'S)) +;; (list 'S (terminal "(") (non-terminal 'S) (terminal ")")) +;; (list 'S (non-terminal 'Q)) +;; (list 'Q (terminal "")) +;; (list 'Q (non-terminal 'Q) (non-terminal 'S)) +;; (list 'Q (terminal "[") (non-terminal 'Q) (terminal "]"))))) +;; Prosze zauważyć, że np. SS zostało zamienione na dwa sąsiednie nieterminalne symbole S +;; (to właśnie powód, dlaczego symbole nieterminalne mogą być jedynie jednoznakowe). + +;; Zdecydowałem się dodać strukturę production, bo wtedy łatwo można na niej operować +;; pisząc funkcje production-add, czy production-lookup itp. + + +(struct non-terminal (sym) #:transparent) +(struct terminal (sym) #:transparent) +(struct grammar (start rules) #:transparent) + +(define SEPARATOR '--) + +(define (split-at-symb symb xs) + (define (iter left right) + (cond + [(null? right) (cons left null)] + [(eq? symb (car right)) (cons left (cdr right))] + [else (iter (cons (car right) left) (cdr right))])) + (let ([res (iter null xs)]) + (cons (reverse (car res)) (cdr res)))) + +(define (split-by-separator xs) + (let ([res (split-at-symb SEPARATOR xs)]) + (if (null? (cdr res)) + res + (cons (car res) (split-by-separator (cdr res)))))) + +(define (make-cfg q) + (cond + [(and (list? q) (eq? 'grammar (first q))) + (grammar (second q) (append-map make-cfg (cddr q)))] + [(and (list? q) (eq? '::= (second q))) + (let ([nt (first q)] + [rules (split-by-separator (cddr q))]) + (map (lambda (x) (cons nt x)) (map make-prod rules)))])) + +(define (symbol->list s) + (map string->symbol + (map string + (string->list (symbol->string s))))) + +(define (make-prod xs) + (cond + [(null? xs) null] + [(string? (car xs)) (cons (terminal (car xs)) (make-prod (cdr xs)))] + [(symbol? (car xs)) (append (map non-terminal (symbol->list (car xs))) (make-prod (cdr xs)))] + [else (error "Invalid syntax in production" xs)])) + + +(define sample '(S ::= "" -- SS -- "(" S ")")) +(define sample2 '(grammar S (S ::= "" -- SS -- "(" S ")" -- Q) (Q ::= "" -- QQ -- "[" Q "]"))) +(define sample3 '(grammar S + (S ::= A B -- D E) + (A ::= "a") + (B ::= "b" C) + (C ::= "c") + (D ::= "d" F) + (E ::= "e") + (F ::= "f" D))) + +;; zadanie 2 + +;; korzystam z algorytmów przedstawionych w tej książce: +;; https://bit.ly/3ev0NUA, konkretnie te ze stron 50-51 +;; Pozwoliłem sobie trochę zmienić przeznaczenie funkcji cfg-unreachable oraz cfg-unproductive +;; Zamiast zwracać nieproduktywne nieterminale, zwracają właśnie produktywne +;; i analogicznie w tym drugim. Po prostu taka implementacja jest dla mnie wygodniejsza, +;; a jest bardzo nieistotną zmianą koncepcyjną. +;; Stąd zmiana nazwy na cfg-productive oraz cfg-reachable + +;; cfg-productive działa w ten sposób: +;; Jakiś nieterminal nazywamy produktywnym, jeśli ma co najmniej jedną produktywną zasadę +;; Jakąś zasadę nazywamy produktywną, jeśli składa się z terminali oraz produktywnych nieterminali +;; Jasno widać, że wg tej definicji te nieterminale, które nie są produktywne, są nieproduktywne +;; wg definicji zadania, a cała reszta jest produktwna. + +;; Algorytm znajdowania produktywnych nieterminali: +;; Mamy listę produktywnych nieterminali P, początkowo pustą +;; 1. Stwórz nową listę P' +;; 2. Przejdź po liście produkcji +;; -> jeśli dana produkcja jest produktywna (wg P), dodaj jej nieterminal do P' +;; 3. Jeśli P != P', zrób P := P' i wróć do 1. +;; 4. Zwróć P + +;; Fajne w tym algorytmie jest to, że jeśli mamy jakiś nieterminal, którego +;; używamy w jakiejś produkcji, ale ten nieterminal nie ma zdefiniowanej swojej produkcji +;; to nie zostanie oznaczony jako produktywny, co jest dla nas korzystne + +;; Algorytm znajdowania osiągalnych nieterminali: +;; Traktujemy nitereminale jak wierzchołki w grafie a zasady jako listy sąsiedztwa. +;; Terminale są liśćmi, a nieterminale węzłami. Robimy po prostu DFSa z nieterminalu +;; startowego i węzły do których dotrzemy oznaczamy jako osiągalne. + +;; Wg papierka który tutaj podałem, jeśli najpierw usuniemy nieproduktywne nieterminale, +;; a w następnej kolejności nieosiągalne, to nasza gramatyka stanie się regularna. + +(define (productive? p productive-nt) + (or (terminal? p) (member (non-terminal-sym p) productive-nt))) +(define (rule-productive? r productive-nt) + (andmap (lambda (x) (productive? x productive-nt)) r)) + +(define (cfg-productive g) + (define (find-productive-nt productive-nt rules) + (cond + [(null? rules) (remove-duplicates productive-nt)] + [(rule-productive? (cdar rules) productive-nt) + (find-productive-nt (cons (caar rules) productive-nt) (cdr rules))] + [else (find-productive-nt productive-nt (cdr rules))])) + (define (iter productive-nt) + (let ([new-prod-nt (find-productive-nt productive-nt (grammar-rules g))]) + (if (equal? productive-nt new-prod-nt) + productive-nt + (iter new-prod-nt)))) + (iter null)) + +(define (cfg-reachable g) + (define (iter verts vis) + (cond + [(null? verts) vis] + [(member (car verts) vis) (iter (cdr verts) vis)] + [else (iter (cdr verts) (dfs (car verts) vis))])) + (define (dfs v vis) + (display v) + (newline) + (let* ([rules (filter (lambda (r) (eq? (car r) v)) (grammar-rules g))] + [verts (append-map (lambda (r) (cdr r)) rules)] + [verts (filter non-terminal? verts)] + [verts (map non-terminal-sym verts)]) + (iter verts (cons v vis)))) + (dfs (grammar-start g) null)) + +(define (cfg-optimize g) + (let* ([productive-nt (cfg-productive g)] + [productive-rules (filter (lambda (r) + (rule-productive? (cdr r) productive-nt)) + (grammar-rules g))] + [new-g (grammar (grammar-start g) productive-rules)] + [reachable-nt (cfg-reachable new-g)] + [res-g (grammar (grammar-start new-g) (filter + (lambda (r) (member (car r) reachable-nt)) + (grammar-rules new-g)))]) + res-g)) +
\ No newline at end of file diff --git a/semestr-2/racket/egzamin/zad3a.rkt b/semestr-2/racket/egzamin/zad3a.rkt new file mode 100644 index 0000000..eaa6645 --- /dev/null +++ b/semestr-2/racket/egzamin/zad3a.rkt @@ -0,0 +1,301 @@ +#lang racket + +;; ZADANIE 3 +;; ========= + +;; Z gramatykami bezkontekstowymi spotkaliście się już na Wstępie do +;; Informatyki. W tym zadaniu potraktujemy je jako dane dla naszych +;; programów. + +;; Przypomnijmy, że gramatyka bezkontekstowa składa się z +;; · skończonego zbioru *symboli nieterminalnych* +;; · skończonego zbioru *symboli terminalnych* +;; · wybranego nieterminalnego symbolu startowego +;; · zbioru *produkcji*, czyli par symbol nieterminalny - lista +;; (potencjalnie pusta) symboli terminalnych lub nieterminalnych + +;; Słowo (ciąg symboli terminalnych) możemy wyprowadzić z gramatyki, +;; jeśli możemy zacząć od ciągu składającego się z symbolu startowego +;; możemy użyć skończonej liczby produkcji z gramatyki przepisując +;; symbol nieterminalny na ciąg symboli mu odpowiadających (w danej +;; produkcji). + + +;; Przykład: poprawne nawiasowania + +;; Gramatyka składa się z jednego symbolu nieterminalnego, S (który +;; jest oczywiście symbolem startowym) i dwóch symboli terminalnych +;; "(" i ")", i zawiera następujące produkcje (zwyczajowo zapisywane +;; przy użyciu strzałki; zwróćcie uwagę że pierwszy ciąg jest pusty!): +;; S -> +;; S -> SS +;; S -> (S) + +;; W często spotykanej, bardziej zwięzłej, postaci BNF moglibyśmy tę +;; gramatykę zapisać tak (dbając trochę bardziej o wizualne +;; oddzielenie symboli terminalnych i nieterminalnych): +;; S ::= "" | SS | "(" S ")" +;; Mamy tu te same produkcje, ale tylko raz zapisujemy każdą z +;; powtarzających się lewych stron. + +;; Z gramatyki tej da się wyprowadzić wszystkie poprawnie rozstawione +;; ciągi nawiasów — zobaczmy jak wyprowadzić (na jeden ze sposobów) +;; ciąg "(()())". Zaczynamy, jak zawsze, od słowa złożonego z symbolu +;; startowego i przepisujemy: +;; S -> (S) -> (SS) -> ((S)S) -> ((S)(S)) -> (()(S)) -> (()()) + + +;; Zadanie cz. 1 + +;; Zdefiniuj reprezentację gramatyki jako typu danych w +;; Rackecie. Warto zastanowić się co można uprościć względem definicji +;; matematycznej — w szczególności możemy założyć że dowolne napisy +;; (typu string) są ciągami symboli terminalnych, i że nie musimy +;; podawać jawnie zbioru nieterminali; również reprezentacja produkcji +;; gramatyki jako worka z parami wejście-wyjście niekoniecznie jest +;; najwygodniejsza. + +;; Uwaga: w tym zadaniu nie wymagamy definiowania składni konkretnej i +;; parsowania, ale bardzo polecamy wybranie jakiejś formy, żeby móc +;; sensownie przetestować swoje rozwiązanie! + + +;; "Optymalizacja" gramatyk + +;; Gramatyki, podobnie jak programy, piszą ludzie — może więc zdarzyć +;; się że znajdą się tam śmieci. Mogą one mieć dwojaką formę: symboli +;; nieterminalnych, których nie da się wyprowadzić z symbolu +;; startowego, lub symboli nieterminalnych z których nie da się +;; wyprowadzić żadnego słowa terminalnego (tj. niezawierającego +;; symboli nieterminalnych). Przykładowo, do naszej gramatyki +;; moglibyśmy dodać symbole P i Q, i produkcje: +;; S -> ")(" P +;; P -> PP "qed" +;; Q -> "abc" + +;; Mimo że nasza gramatyka wygląda inaczej na pierwszy rzut oka, tak +;; naprawdę się nie zmieniła: do symbolu Q nie możemy dojść z symbolu +;; S, a więc "abc" nigdy nie wystąpi w słowie wyprowadzalnym z +;; gramatyki. Analogicznie, z P nie da się wyprowadzić żadnego słowa, +;; które nie zawierałoby symbolu P — a zatem żadnego słowa złożonego +;; tylko z symboli terminalnych. To znaczy, że naszą gramatykę możemy +;; uprościć wyrzucając z niej symbole nieterminalne (i produkcje które +;; ich używają) do których nie da się dojść (tj. są *nieosiągalne*) i +;; te, z których nie da się ułożyć słowa terminalnego (tj. są +;; *nieproduktywne*). Jeśli z naszej rozszerzonej gramatyki wyrzucimy +;; takie symbole, dostaniemy oczywiście gramatykę początkową. + + +;; Zadanie cz. 2 + +;; Dla swojej reprezentacji gramatyki z poprzedniej części zadania +;; napisz dwie procedury: cfg-unreachable, znajdującą symbole +;; nieterminalne które są nieosiągalne z symbolu startowego, i +;; cfg-unproductive, znajdującą symbole nieterminalne które nie są +;; produktywne. Następnie użyj tych procedur żeby zdefiniować +;; procedurę cfg-optimize, która uprości daną gramatykę usuwając z +;; niej symbole nieosiągalne i nieproduktywne, a także odpowiednie +;; produkcje. + +;; Rozwiązanie wpisz w poniższym pliku, i opatrz komentarzem +;; opisującym wybraną reprezentację (i podjęte przy jej projektowaniu +;; decyzje), a także zaimplementowane w cz. 2. algorytmy. + + + + + + +;; Zadanie 1 + +;; Postanowiłem napisać parser, bo bez tego zadanie wydaje mi się dosyć ubogie +;; Składnia konkretna naszych gramatyk wygląda bardzo podobnie do zapisu +;; przedstawionego w treści zadania. +;; np. gramatyka nawiasowania będzie wyglądać następująco: +;; '(grammar S (S ::= "" -- SS -- "(" S ")")) +;; ale mogłaby wyglądać też tak: +;; '(grammar S (S ::= "") (S ::= SS -- "(" S ")")) +;; a np. ta nieciekawa gramatyka przedstawiona w treści zadania: +;; '(grammar S (S ::= "] [" P) (P ::= PP "qed") (Q ::= "abc")) +;; Zatem będzie to lista, która na pierwszym miejscu ma symbol 'grammar +;; na drugim miejscu ma symbol startowy +;; następnie następuje lista produkcji w formacie: +;; <non-terminal> ::= <lista produkcji, produkcje oddzielone są separatorem --> +;; Zalety: +;; - rozróżnienie w składni konkretnej symboli nieterminalnych i terminalnych +;; przez użycie symboli i stringów pozwala na to, aby symbole terminalne nazywały się tak +;; jak terminalne, tj. "S" nie jest tym samym co 'S. +;; - składnia wydaje się bardzo wygodna w użyciu, nie ma też problemu, żeby później dopisać +;; dodatkowe produkcje dla jednego symbolu nieterminalnego, np. (S ::= "") (S ::= SS) +;; - parser jest łatwy w implementacji +;; Wady: +;; - symbole nieterminalne mogą składać się jedynie z jednego symbolu, zatem nie możemy robić ich +;; zbyt wiele + +;; Reprezentacja gramatyki: podczas parsowania gramatyki symbole i stringi wewnątrz produkcji +;; reprezentowane są przez struktury terminal oraz non-terminal. Cała gramatyka to +;; struktura dwuelementowa - pierwszym jest symbol startowy, a drugim lista par <symbol . produkcja> +;; Taka decyzja właśnie pozwoliła na to, że zaproponowana przeze mnie składania konkretna jest +;; bardzo prosta do sparsowania - wystarczy każdą produkcję podzielić ze względu na separator '-- +;; i do czegoś podobnego do środowisk dodawać po prostu odpowiednie pary. +;; dla przykładu taka gramatyka: +;; '(grammar S (S ::= "" -- SS -- "(" S ")" -- Q) (Q ::= "" -- QS -- "[" Q "]")) +;; będzie reprezentowana następująco: +;; (grammar +;; 'S +;; (production +;; (list +;; (list 'S (terminal "")) +;; (list 'S (non-terminal 'S) (non-terminal 'S)) +;; (list 'S (terminal "(") (non-terminal 'S) (terminal ")")) +;; (list 'S (non-terminal 'Q)) +;; (list 'Q (terminal "")) +;; (list 'Q (non-terminal 'Q) (non-terminal 'S)) +;; (list 'Q (terminal "[") (non-terminal 'Q) (terminal "]"))))) +;; Prosze zauważyć, że np. SS zostało zamienione na dwa sąsiednie nieterminalne symbole S +;; (to właśnie powód, dlaczego symbole nieterminalne mogą być jedynie jednoznakowe). + +;; Zdecydowałem się dodać strukturę production, bo wtedy łatwo można na niej operować +;; pisząc funkcje production-add, czy production-lookup itp. + + +(struct non-terminal (sym) #:transparent) +(struct terminal (sym) #:transparent) +(struct grammar (start rules) #:transparent) + +(define SEPARATOR '--) + +(define (make-cfg q) + (cond + [(and (list? q) (eq? 'grammar (first q))) + (grammar (second q) (append-map make-cfg (cddr q)))] + [(and (list? q) (eq? '::= (second q))) + (let ([nt (first q)] + [rules (split-by-separator (cddr q))]) + (map (lambda (x) (cons nt x)) (map make-rules rules)))] + [else (error "MAKE-CFG -- Parse error, unknown token" q)])) + +(define (make-cfg start rules) + (grammar start (make-rules rules))) + +(define (make-rules xs) + (cond + [(null? xs) null] + [(string? (car xs)) (cons (terminal (car xs)) (make-rules (cdr xs)))] + [(symbol? (car xs)) (append (map non-terminal (symbol->list (car xs))) (make-rules (cdr xs)))] + [else (error "Invalid syntax in production" xs)])) + +(define (split-at-symb symb xs) + (define (iter left right) + (cond + [(null? right) (cons left null)] + [(eq? symb (car right)) (cons left (cdr right))] + [else (iter (cons (car right) left) (cdr right))])) + (let ([res (iter null xs)]) + (cons (reverse (car res)) (cdr res)))) + +(define (split-by-separator xs) + (let ([res (split-at-symb SEPARATOR xs)]) + (if (null? (cdr res)) + res + (cons (car res) (split-by-separator (cdr res)))))) + +(define (symbol->list s) + (map string->symbol + (map string + (string->list (symbol->string s))))) + +(define sample '(S ::= "" -- SS -- "(" S ")")) +(define sample2 '(grammar S (S ::= "" -- SS -- "(" S ")" -- Q) (Q ::= "" -- QQ -- "[" Q "]"))) +(define sample3 '(grammar S + (S ::= A B -- D E) + (A ::= "a") + (B ::= "b" C) + (C ::= "c") + (D ::= "d" F) + (E ::= "e") + (F ::= "f" D))) + +;; zadanie 2 + +;; korzystam z algorytmów przedstawionych w tej książce: +;; https://bit.ly/3ev0NUA, konkretnie te ze stron 50-51 +;; Pozwoliłem sobie trochę zmienić przeznaczenie funkcji cfg-unreachable oraz cfg-unproductive +;; Zamiast zwracać nieproduktywne nieterminale, zwracają właśnie produktywne +;; i analogicznie w tym drugim. Po prostu taka implementacja jest dla mnie wygodniejsza, +;; a jest bardzo nieistotną zmianą koncepcyjną. +;; Stąd zmiana nazwy na cfg-productive oraz cfg-reachable + +;; cfg-productive działa w ten sposób: +;; Jakiś nieterminal nazywamy produktywnym, jeśli ma co najmniej jedną produktywną zasadę +;; Jakąś zasadę nazywamy produktywną, jeśli składa się z terminali oraz produktywnych nieterminali +;; Jasno widać, że wg tej definicji te nieterminale, które nie są produktywne, są nieproduktywne +;; wg definicji zadania, a cała reszta jest produktwna. + +;; Algorytm znajdowania produktywnych nieterminali: +;; Mamy listę produktywnych nieterminali P, początkowo pustą +;; 1. Stwórz nową listę P' +;; 2. Przejdź po liście produkcji +;; -> jeśli dana produkcja jest produktywna (wg P), dodaj jej nieterminal do P' +;; 3. Jeśli P != P', zrób P := P' i wróć do 1. +;; 4. Zwróć P + +;; Fajne w tym algorytmie jest to, że jeśli mamy jakiś nieterminal, którego +;; używamy w jakiejś produkcji, ale ten nieterminal nie ma zdefiniowanej swojej produkcji +;; to nie zostanie oznaczony jako produktywny, co jest dla nas korzystne + +;; Algorytm znajdowania osiągalnych nieterminali: +;; Traktujemy nitereminale jak wierzchołki w grafie a zasady jako listy sąsiedztwa. +;; Terminale są liśćmi, a nieterminale węzłami. Robimy po prostu DFSa z nieterminalu +;; startowego i węzły do których dotrzemy oznaczamy jako osiągalne. + +;; Wg papierka który tutaj podałem, jeśli najpierw usuniemy nieproduktywne nieterminale, +;; a w następnej kolejności nieosiągalne, to nasza gramatyka stanie się regularna. + +(define (productive? p productive-nt) + (or (terminal? p) (member (non-terminal-sym p) productive-nt))) +(define (rule-productive? r productive-nt) + (andmap (lambda (x) (productive? x productive-nt)) r)) + +(define (cfg-productive g) + (define (find-productive-nt productive-nt rules) + (cond + [(null? rules) (remove-duplicates productive-nt)] + [(rule-productive? (cdar rules) productive-nt) + (find-productive-nt (cons (caar rules) productive-nt) (cdr rules))] + [else (find-productive-nt productive-nt (cdr rules))])) + (define (iter productive-nt) + (let ([new-prod-nt (find-productive-nt productive-nt (grammar-rules g))]) + (if (equal? productive-nt new-prod-nt) + productive-nt + (iter new-prod-nt)))) + (iter null)) + +(define (cfg-reachable g) + (define (iter verts vis) + (cond + [(null? verts) vis] + [(member (car verts) vis) (iter (cdr verts) vis)] + [else (iter (cdr verts) (dfs (car verts) vis))])) + (define (dfs v vis) + (display v) + (newline) + (let* ([rules (filter (lambda (r) (eq? (car r) v)) (grammar-rules g))] + [verts (append-map (lambda (r) (cdr r)) rules)] + [verts (filter non-terminal? verts)] + [verts (map non-terminal-sym verts)]) + (iter verts (cons v vis)))) + (dfs (grammar-start g) null)) + +(define (cfg-optimize g) + (let* ([productive-nt (cfg-productive g)] + [productive-rules (filter (lambda (r) + (rule-productive? (cdr r) productive-nt)) + (grammar-rules g))] + [new-g (grammar (grammar-start g) productive-rules)] + [reachable-nt (cfg-reachable new-g)] + [res-g (grammar (grammar-start new-g) (filter + (lambda (r) (member (car r) reachable-nt)) + (grammar-rules new-g)))]) + res-g)) +
\ No newline at end of file diff --git a/semestr-2/racket/l10z18/solution.bak b/semestr-2/racket/l10z18/solution.bak new file mode 100644 index 0000000..02eb770 --- /dev/null +++ b/semestr-2/racket/l10z18/solution.bak @@ -0,0 +1,363 @@ +#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) + +(define (keyword s) + (member s '(true false null and or if cond else lambda let letrec))) + +(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) #:transparent) + +;; Pomocnicze konstruktory procedur unarnych i binarnych +(define (builtin/1 p) + (builtin (lambda (x) (return (p x))) null 1)) +(define (builtin/2 p) + (builtin (lambda (x y) (return (p x y))) 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 + ))) + +;; Efekt + +(define (effect-builtin/1 p) + (builtin p null 1)) +(define (effect-builtin/2 p) + (builtin p null 2)) + +(define effect-env + (foldl (lambda (p env) (env-add (first p) (second p) env)) + start-env + `((choose ,(effect-builtin/2 (lambda (x y) (list x y)))) + ))) + +(define (bind c k) (append-map k c)) + +(define (return x) (list x)) + +;; Ewaluator +(define (eval-env e env) + (match e + [(const n) + (return n)] + + [(var-expr x) + (return (env-lookup x env))] + + [(let-expr x e1 e2) + (bind (eval-env e1 env) (lambda (v1) + (eval-env e2 (env-add x v1 env))))] + + [(letrec-expr f ef eb) + (let ((new-env (env-add f (blackhole) env))) + (bind (eval-env ef new-env) (lambda (vf) + (env-update! f vf new-env) + (eval-env eb new-env))))] + + [(if-expr eb et ef) + (bind (eval-env eb env) (lambda (vb) + (match vb + [#t (eval-env et env)] + [#f (eval-env ef env)] + [v (error "Not a boolean:" v)])))] + + [(lambda-expr x e) + (return (clo x e env))] + + [(app-expr ef ea) + (bind (eval-env ef env) (lambda (vf) + (bind (eval-env ea env) (lambda (va) + (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))) + (return (builtin p (cons va args) (- nm 1))))] + [_ (error "Not a function:" vf)])))))])) + +(define (eval e) + (eval-env e effect-env)) + + +;; Przykladowy program + +(define PROGRAM + '((if (choose true false) (lambda (x) x) (lambda (x) (+ x 1))) (choose 1 2))) + + +;; 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 diff --git a/semestr-2/racket/l10z18/solution.rkt b/semestr-2/racket/l10z18/solution.rkt new file mode 100644 index 0000000..7adcea4 --- /dev/null +++ b/semestr-2/racket/l10z18/solution.rkt @@ -0,0 +1,409 @@ +#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) + +(provide parse eval norm) + +(define (keyword s) + (member s '(true false null and or if cond else lambda let letrec))) + +(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) #:transparent) + +;; Pomocnicze konstruktory procedur unarnych i binarnych +(define (builtin/1 p) + (builtin (lambda (x) (return (p x))) null 1)) +(define (builtin/2 p) + (builtin (lambda (x y) (return (p x y))) 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 + ))) + +;; Efekt + +(define (effect-builtin/1 p) + (builtin p null 1)) +(define (effect-builtin/2 p) + (builtin p null 2)) +(define (effect-builtin/3 p) + (builtin p null 3)) + + +(define effect-env + (foldl (lambda (p env) (env-add (first p) (second p) env)) + start-env + `((flip ,(effect-builtin/3 (lambda (p x y) (list (cons p x) (cons (- 1 p) y))))) + (uniform ,(effect-builtin/1 (lambda (x) (let ((l (/ 1 (length x)))) + (map (lambda (x) (cons l x)) x))))) + ))) + +;; c to lista par (pstwo, wartość) +;; k to funkcja która przyjmuje wartość i coś z nią robi sobie i zwraca listę par (pstwo, wartość) + +(define (bind c k) + (append-map + (lambda (x) (let ((pstwo (car x)) + (val (cdr x))) + (map + (lambda (x) (cons (* pstwo (car x)) (cdr x))) + (k (cdr x))))) + c)) + +(define (return x) (list (cons 1 x))) + +;; Ewaluator +(define (eval-env e env) + (match e + [(const n) + (return n)] + + [(var-expr x) + (return (env-lookup x env))] + + [(let-expr x e1 e2) + (bind (eval-env e1 env) (lambda (v1) + (eval-env e2 (env-add x v1 env))))] + + [(letrec-expr f ef eb) + (let ((new-env (env-add f (blackhole) env))) + (bind (eval-env ef new-env) (lambda (vf) + (env-update! f vf new-env) + (eval-env eb new-env))))] + + [(if-expr eb et ef) + (bind (eval-env eb env) (lambda (vb) + (match vb + [#t (eval-env et env)] + [#f (eval-env ef env)] + [v (error "Not a boolean:" v)])))] + + [(lambda-expr x e) + (return (clo x e env))] + + [(app-expr ef ea) + (bind (eval-env ef env) (lambda (vf) + (bind (eval-env ea env) (lambda (va) + (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))) + (return (builtin p (cons va args) (- nm 1))))] + [_ (error "Not a function:" vf)])))))])) + +(define (eval e) + (eval-env e effect-env)) + + +;; Przykladowy program + +(define PROGRAM + '((if (choose true false) (lambda (x) x) (lambda (x) (+ x 1))) (choose 1 2))) + + +;; 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)) + + +(define prog '(if (flip 0.3 true false) "wygrana" "przegrana")) + + +(define (norm xs) + (define sum (lambda (xs) (foldl + 0 xs))) + (define carlist (lambda (xs) (map car xs))) + (define (iter xs res) + (cond + [(null? xs) res] + [(member (cdar xs) (map cdr res)) (iter (cdr xs) res)] + [else (let* ((cur (cdar xs)) + (pstwa (filter (lambda (x) (equal? (cdr x) cur)) xs))) + (iter (cdr xs) (cons (cons (sum (carlist pstwa)) cur) res)))])) + (iter xs null)) + + +(define DICE-MANY + '(letrec [from-to (lambda (x n) + (cons x + (if (= x n) + null + (from-to (+ 1 x) n))))] + (let [dice (lambda (x) (uniform (from-to 1 6)))] + (letrec [dice-many (lambda (n) (if (= n 0) + 0 + (+ (dice 0) (dice-many (- n 1)))))] + (dice-many (dice 0))))))
\ No newline at end of file diff --git a/semestr-2/racket/l11/rozw.bak b/semestr-2/racket/l11/rozw.bak new file mode 100644 index 0000000..cda82ce --- /dev/null +++ b/semestr-2/racket/l11/rozw.bak @@ -0,0 +1,2 @@ +#lang racket + diff --git a/semestr-2/racket/l11/rozw.rkt b/semestr-2/racket/l11/rozw.rkt new file mode 100644 index 0000000..e45e403 --- /dev/null +++ b/semestr-2/racket/l11/rozw.rkt @@ -0,0 +1,776 @@ +#reader(lib"read.ss""wxme")WXME0109 ## +#| + This file uses the GRacket editor format. + Open this file in DrRacket version 7.6 or later to read it. + + Most likely, it was created by saving a program in DrRacket, + and it probably contains a program with non-text elements + (such as images or comment boxes). + + http://racket-lang.org/ +|# + 33 7 #"wxtext\0" +3 1 6 #"wxtab\0" +1 1 8 #"wximage\0" +2 0 8 #"wxmedia\0" +4 1 34 #"(lib \"syntax-browser.ss\" \"mrlib\")\0" +1 0 36 #"(lib \"cache-image-snip.ss\" \"mrlib\")\0" +1 0 68 +(0 + #"((lib \"image-core.ss\" \"mrlib\") (lib \"image-core-wxme.rkt\" \"mr" + #"lib\"))\0" +) 1 0 16 #"drscheme:number\0" +3 0 44 #"(lib \"number-snip.ss\" \"drscheme\" \"private\")\0" +1 0 36 #"(lib \"comment-snip.ss\" \"framework\")\0" +1 0 93 +(1 + #"((lib \"collapsed-snipclass.ss\" \"framework\") (lib \"collapsed-sni" + #"pclass-wxme.ss\" \"framework\"))\0" +) 0 0 43 #"(lib \"collapsed-snipclass.ss\" \"framework\")\0" +0 0 19 #"drscheme:sexp-snip\0" +0 0 29 #"drscheme:bindings-snipclass%\0" +1 0 101 +(2 + #"((lib \"ellipsis-snip.rkt\" \"drracket\" \"private\") (lib \"ellipsi" + #"s-snip-wxme.rkt\" \"drracket\" \"private\"))\0" +) 2 0 88 +(3 + #"((lib \"pict-snip.rkt\" \"drracket\" \"private\") (lib \"pict-snip.r" + #"kt\" \"drracket\" \"private\"))\0" +) 0 0 55 +#"((lib \"snip.rkt\" \"pict\") (lib \"snip-wxme.rkt\" \"pict\"))\0" +1 0 34 #"(lib \"bullet-snip.rkt\" \"browser\")\0" +0 0 25 #"(lib \"matrix.ss\" \"htdp\")\0" +1 0 22 #"drscheme:lambda-snip%\0" +1 0 29 #"drclickable-string-snipclass\0" +0 0 26 #"drracket:spacer-snipclass\0" +0 0 57 +#"(lib \"hrule-snip.rkt\" \"macro-debugger\" \"syntax-browser\")\0" +1 0 26 #"drscheme:pict-value-snip%\0" +0 0 45 #"(lib \"image-snipr.ss\" \"slideshow\" \"private\")\0" +1 0 38 #"(lib \"pict-snipclass.ss\" \"slideshow\")\0" +2 0 55 #"(lib \"vertical-separator-snip.ss\" \"stepper\" \"private\")\0" +1 0 18 #"drscheme:xml-snip\0" +1 0 31 #"(lib \"xml-snipclass.ss\" \"xml\")\0" +1 0 21 #"drscheme:scheme-snip\0" +2 0 34 #"(lib \"scheme-snipclass.ss\" \"xml\")\0" +1 0 10 #"text-box%\0" +1 0 32 #"(lib \"text-snipclass.ss\" \"xml\")\0" +1 0 1 6 #"wxloc\0" + 0 0 81 0 1 #"\0" +0 75 1 #"\0" +0 10 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 9 +#"Standard\0" +0 75 12 #"Courier New\0" +0 16 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 24 +#"framework:default-color\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 255 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 15 +#"text:ports out\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 119 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1.0 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 255 0 0 0 0 0 -1 +-1 2 15 #"text:ports err\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 204 204 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 17 +#"text:ports value\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 144 179 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1.0 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 34 139 34 0 0 0 -1 +-1 2 27 #"Matching Parenthesis Style\0" +0 -1 1 #"\0" +1.0 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 34 139 34 0 0 0 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 37 +#"framework:syntax-color:scheme:symbol\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 144 179 255 0 0 0 -1 -1 2 +38 #"framework:syntax-color:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 144 179 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +38 #"framework:syntax-color:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 204 221 170 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 37 +#"framework:syntax-color:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 144 179 255 0 0 0 -1 -1 2 +35 #"framework:syntax-color:scheme:text\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 144 179 255 0 0 0 -1 -1 2 +39 #"framework:syntax-color:scheme:constant\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 144 179 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 49 +#"framework:syntax-color:scheme:hash-colon-keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 144 179 255 0 0 0 -1 -1 2 +42 #"framework:syntax-color:scheme:parenthesis\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 178 178 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 36 +#"framework:syntax-color:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 204 204 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 36 +#"framework:syntax-color:scheme:other\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 144 179 255 0 0 0 -1 -1 2 +16 #"Misspelled Text\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 255 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 +38 #"drracket:check-syntax:lexically-bound\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 50 163 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 28 +#"drracket:check-syntax:set!d\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 204 204 0 0 0 -1 -1 2 +37 #"drracket:check-syntax:unused-require\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 204 204 0 0 0 -1 -1 2 +36 #"drracket:check-syntax:free-variable\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 204 204 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 31 +#"drracket:check-syntax:imported\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 166 0 255 0 0 0 -1 -1 2 47 +#"drracket:check-syntax:my-obligation-style-pref\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 192 203 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 116 0 0 0 0 -1 -1 2 50 +#"drracket:check-syntax:their-obligation-style-pref\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 50 205 50 0 0 0 -1 -1 2 48 +#"drracket:check-syntax:unk-obligation-style-pref\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 255 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 139 142 28 0 0 0 -1 -1 2 +49 #"drracket:check-syntax:both-obligation-style-pref\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 240 230 140 0 0 0 -1 -1 2 +26 #"plt:htdp:test-coverage-on\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 255 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 2 27 +#"plt:htdp:test-coverage-off\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 205 92 92 0 0 0 -1 -1 4 1 +#"\0" +0 70 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 4 4 #"XML\0" +0 70 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 2 37 #"plt:module-language:test-coverage-on\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 255 255 0 0 0 -1 -1 2 +38 #"plt:module-language:test-coverage-off\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 205 92 92 0 0 0 -1 -1 0 36 +#"mrlib/syntax-browser:subtitle-color\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 100 149 237 0 0 0 -1 -1 0 +42 #"mrlib/syntax-browser:focused-syntax-color\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 50 205 50 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 4 1 #"\0" +0 -1 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1.0 1.0 1.0 0 191 255 0 0 0 -1 +-1 4 1 #"\0" +0 71 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1.0 1.0 1.0 0 191 255 0 0 0 -1 +-1 4 1 #"\0" +0 71 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 152 251 152 0 0 0 +-1 -1 4 32 #"widget.rkt::browser-text% basic\0" +0 70 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 4 59 +#"macro-debugger/syntax-browser/properties color-text% basic\0" +0 70 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 58 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 190 190 190 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 200 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 255 255 0 0 0 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 185 220 113 0 0 0 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 155 255 155 0 0 0 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 116 116 0 0 0 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 18 67 155 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 30 70 190 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 75 135 185 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 176 208 208 0 0 0 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 116 116 255 0 0 0 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 200 125 255 0 0 0 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 143 15 223 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 165 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 141 19 5 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 244 194 71 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 255 127 0 0 0 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 86 86 86 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 255 0 31 31 -1 -1 +4 1 #"\0" +0 -1 1 #"\0" +1.0 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 0 -1 -1 + 0 475 0 28 3 12 #"#lang racket" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 7 #"require" +0 0 24 3 1 #" " +0 0 14 3 15 #"racket/contract" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 17 3 13 #";;; Zadanie 1" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 15 #"define/contract" +0 0 24 3 2 #" (" +0 0 14 3 8 #"suffixes" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 14 #"parametric->/c" +0 0 24 3 2 #" [" +0 0 14 3 1 #"a" +0 0 24 3 3 #"] (" +0 0 14 3 2 #"->" +0 0 24 3 2 #" (" +0 0 14 3 6 #"listof" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 3 #") (" +0 0 14 3 6 #"listof" +0 0 24 3 2 #" (" +0 0 14 3 6 #"listof" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 5 #")))) " +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 2 #"if" +0 0 24 3 2 #" (" +0 0 14 3 5 #"null?" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 6 #" " +0 0 14 3 4 #"null" +0 0 24 29 1 #"\n" +0 0 24 3 7 #" (" +0 0 14 3 4 #"cons" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 2 #" (" +0 0 14 3 8 #"suffixes" +0 0 24 3 2 #" (" +0 0 14 3 3 #"cdr" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 5 #")))))" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 17 3 13 #";;; Zadanie 2" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 15 #"define/contract" +0 0 24 3 2 #" (" +0 0 14 3 8 #"sublists" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 14 #"parametric->/c" +0 0 24 3 2 #" [" +0 0 14 3 1 #"a" +0 0 24 3 3 #"] (" +0 0 14 3 2 #"->" +0 0 24 3 2 #" (" +0 0 14 3 6 #"listof" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 3 #") (" +0 0 14 3 6 #"listof" +0 0 24 3 2 #" (" +0 0 14 3 6 #"listof" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 6 #")))) " +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 2 #"if" +0 0 24 3 2 #" (" +0 0 14 3 5 #"null?" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 7 #" (" +0 0 14 3 4 #"list" +0 0 24 3 1 #" " +0 0 14 3 4 #"null" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 7 #" (" +0 0 14 3 10 #"append-map" +0 0 24 29 1 #"\n" +0 0 24 3 8 #" (" +0 0 15 3 6 #"lambda" +0 0 24 3 2 #" (" +0 0 14 3 2 #"ys" +0 0 24 3 3 #") (" +0 0 14 3 4 #"list" +0 0 24 3 2 #" (" +0 0 14 3 4 #"cons" +0 0 24 3 2 #" (" +0 0 14 3 3 #"car" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 2 #") " +0 0 14 3 2 #"ys" +0 0 24 3 2 #") " +0 0 14 3 2 #"ys" +0 0 24 3 2 #"))" +0 0 24 29 1 #"\n" +0 0 24 3 8 #" (" +0 0 14 3 8 #"sublists" +0 0 24 3 2 #" (" +0 0 14 3 3 #"cdr" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 5 #")))))" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 17 3 13 #";;; Zadanie 3" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 15 #"define/contract" +0 0 24 3 2 #" (" +0 0 14 3 17 #"autistic-identity" +0 0 24 3 1 #" " +0 0 14 3 1 #"x" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 14 #"parametric->/c" +0 0 24 3 2 #" [" +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 3 #"] (" +0 0 14 3 2 #"->" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 2 #"))" +0 0 24 29 1 #"\n" +0 0 24 3 2 #" " +0 0 14 3 1 #"x" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 15 #"define/contract" +0 0 24 3 2 #" (" +0 0 14 3 6 #"create" +0 0 24 3 1 #" " +0 0 14 3 4 #"comb" +0 0 24 3 1 #" " +0 0 14 3 4 #"next" +0 0 24 3 1 #" " +0 0 14 3 3 #"beg" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 14 #"parametric->/c" +0 0 24 3 2 #" [" +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 1 #" " +0 0 14 3 1 #"c" +0 0 24 3 3 #"] (" +0 0 14 3 2 #"->" +0 0 24 3 2 #" (" +0 0 14 3 2 #"->" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 1 #" " +0 0 14 3 1 #"c" +0 0 24 3 3 #") (" +0 0 14 3 2 #"->" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 2 #") " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"c" +0 0 24 3 2 #"))" +0 0 24 29 1 #"\n" +0 0 24 3 4 #" ((" +0 0 14 3 4 #"comb" +0 0 24 3 2 #" (" +0 0 14 3 4 #"next" +0 0 24 3 1 #" " +0 0 14 3 3 #"beg" +0 0 24 3 2 #") " +0 0 14 3 3 #"beg" +0 0 24 3 3 #")))" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 15 #"define/contract" +0 0 24 3 2 #" (" +0 0 14 3 7 #"compose" +0 0 24 3 1 #" " +0 0 14 3 2 #"bc" +0 0 24 3 1 #" " +0 0 14 3 2 #"ab" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 14 #"parametric->/c" +0 0 24 3 2 #" [" +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 1 #" " +0 0 14 3 1 #"c" +0 0 24 3 3 #"] (" +0 0 14 3 2 #"->" +0 0 24 3 2 #" (" +0 0 14 3 2 #"->" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 1 #" " +0 0 14 3 1 #"c" +0 0 24 3 3 #") (" +0 0 14 3 2 #"->" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 3 #") (" +0 0 14 3 2 #"->" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"c" +0 0 24 3 3 #")))" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 15 3 6 #"lambda" +0 0 24 3 2 #" (" +0 0 14 3 1 #"x" +0 0 24 3 3 #") (" +0 0 14 3 2 #"bc" +0 0 24 3 2 #" (" +0 0 14 3 2 #"ab" +0 0 24 3 1 #" " +0 0 14 3 1 #"x" +0 0 24 3 4 #"))))" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 15 #"define/contract" +0 0 24 3 2 #" (" +0 0 14 3 5 #"ident" +0 0 24 3 1 #" " +0 0 14 3 1 #"f" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 14 #"parametric->/c" +0 0 24 3 2 #" [" +0 0 14 3 1 #"a" +0 0 24 3 3 #"] (" +0 0 14 3 2 #"->" +0 0 24 3 2 #" (" +0 0 14 3 2 #"->" +0 0 24 3 2 #" (" +0 0 14 3 2 #"->" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 2 #") " +0 0 14 3 1 #"a" +0 0 24 3 2 #") " +0 0 14 3 1 #"a" +0 0 24 3 2 #"))" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 1 #"f" +0 0 24 3 1 #" " +0 0 14 3 8 #"identity" +0 0 24 3 2 #"))" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 17 3 13 #";;; Zadanie 4" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 15 #"define/contract" +0 0 24 3 2 #" (" +0 0 14 3 12 #"broken-contr" +0 0 24 3 1 #" " +0 0 14 3 1 #"x" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 14 #"parametric->/c" +0 0 24 3 2 #" [" +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 3 #"] (" +0 0 14 3 2 #"->" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 1 #"b" +0 0 24 3 2 #"))" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 12 #"broken-contr" +0 0 24 3 1 #" " +0 0 14 3 1 #"x" +0 0 24 3 2 #"))" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 17 3 13 #";;; Zadanie 5" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 15 #"define/contract" +0 0 24 3 2 #" (" +0 0 14 3 9 #"foldl-map" +0 0 24 3 1 #" " +0 0 14 3 1 #"f" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 14 #"parametric->/c" +0 0 24 3 2 #" [" +0 0 14 3 1 #"F" +0 0 24 3 1 #" " +0 0 14 3 1 #"A" +0 0 24 3 1 #" " +0 0 14 3 1 #"L" +0 0 24 3 3 #"] (" +0 0 14 3 2 #"->" +0 0 24 3 2 #" (" +0 0 14 3 2 #"->" +0 0 24 3 1 #" " +0 0 14 3 1 #"L" +0 0 24 3 1 #" " +0 0 14 3 1 #"A" +0 0 24 3 2 #" (" +0 0 14 3 6 #"cons/c" +0 0 24 3 1 #" " +0 0 14 3 1 #"F" +0 0 24 3 1 #" " +0 0 14 3 1 #"A" +0 0 24 3 3 #")) " +0 0 14 3 1 #"A" +0 0 24 3 2 #" (" +0 0 14 3 6 #"listof" +0 0 24 3 1 #" " +0 0 14 3 1 #"L" +0 0 24 3 3 #") (" +0 0 14 3 6 #"cons/c" +0 0 24 3 2 #" (" +0 0 14 3 6 #"listof" +0 0 24 3 1 #" " +0 0 14 3 1 #"F" +0 0 24 3 2 #") " +0 0 14 3 1 #"A" +0 0 24 3 4 #"))) " +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 15 3 6 #"define" +0 0 24 3 2 #" (" +0 0 14 3 2 #"it" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 1 #" " +0 0 14 3 2 #"ys" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 5 #" (" +0 0 14 3 2 #"if" +0 0 24 3 2 #" (" +0 0 14 3 5 #"null?" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 9 #" (" +0 0 14 3 4 #"cons" +0 0 24 3 2 #" (" +0 0 14 3 7 #"reverse" +0 0 24 3 1 #" " +0 0 14 3 2 #"ys" +0 0 24 3 2 #") " +0 0 14 3 1 #"a" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 9 #" (" +0 0 15 3 3 #"let" +0 0 24 3 3 #" [(" +0 0 14 3 1 #"p" +0 0 24 3 2 #" (" +0 0 14 3 1 #"f" +0 0 24 3 2 #" (" +0 0 14 3 3 #"car" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 2 #") " +0 0 14 3 1 #"a" +0 0 24 3 3 #"))]" +0 0 24 29 1 #"\n" +0 0 24 3 11 #" (" +0 0 14 3 2 #"it" +0 0 24 3 2 #" (" +0 0 14 3 3 #"cdr" +0 0 24 3 1 #" " +0 0 14 3 1 #"p" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 15 #" (" +0 0 14 3 3 #"cdr" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 15 #" (" +0 0 14 3 4 #"cons" +0 0 24 3 2 #" (" +0 0 14 3 3 #"car" +0 0 24 3 1 #" " +0 0 14 3 1 #"p" +0 0 24 3 2 #") " +0 0 14 3 2 #"ys" +0 0 24 3 5 #")))))" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 2 #"it" +0 0 24 3 1 #" " +0 0 14 3 1 #"a" +0 0 24 3 1 #" " +0 0 14 3 2 #"xs" +0 0 24 3 1 #" " +0 0 14 3 4 #"null" +0 0 24 3 2 #"))" +0 0 diff --git a/semestr-2/racket/l11/solution.bak b/semestr-2/racket/l11/solution.bak new file mode 100644 index 0000000..3ae167a --- /dev/null +++ b/semestr-2/racket/l11/solution.bak @@ -0,0 +1,18 @@ +#lang racket + +(require racket/contract) + +(provide (contract-out [square square/c])) +(provide square/c) + +(define square/c (-> number? (not/c negative?))) + +(define (square x) (* x x)) + + +(define with-labels/c (parametric->/c [a b] (-> (-> a b)) + +(define (with-labels f xs) + (if (null? xs) + null + (cons (list (f (car xs)) (car xs)) (with-labels f (cdr xs)))))
\ No newline at end of file diff --git a/semestr-2/racket/l11/solution.rkt b/semestr-2/racket/l11/solution.rkt new file mode 100644 index 0000000..55e4ba6 --- /dev/null +++ b/semestr-2/racket/l11/solution.rkt @@ -0,0 +1,35 @@ +#lang racket + +(provide (contract-out + [with-labels with-labels/c] + [foldr-map foldr-map/c] + [pair-from pair-from/c])) +(provide with-labels/c foldr-map/c pair-from/c) + + +(define with-labels/c (parametric->/c [a b] (-> (-> a b) (listof a) (listof (cons/c b (cons/c a null?)))))) + +(define (with-labels f xs) + (if (null? xs) + null + (cons (list (f (car xs)) (car xs)) (with-labels f (cdr xs))))) + + + +(define foldr-map/c (parametric->/c [x a f] (-> (-> x a (cons/c f a)) a (listof x) (cons/c (listof f) a)))) + +(define (foldr-map f a xs) + (define (it a xs ys) + (if (null? xs) + (cons ys a) + (let [(p (f (car xs) a))] + (it (cdr p) + (cdr xs) + (cons (car p) ys))))) + (it a (reverse xs) null)) + + +(define pair-from/c (parametric->/c [x fx gx] (-> (-> x fx) (-> x gx) (-> x (cons/c fx gx))))) + +(define (pair-from f g) + (lambda (x) (cons (f x) (g x))))
\ No newline at end of file diff --git a/semestr-2/racket/l11z20/compiled/drracket/errortrace/graph_rkt.dep b/semestr-2/racket/l11z20/compiled/drracket/errortrace/graph_rkt.dep new file mode 100644 index 0000000..6d38ce0 --- /dev/null +++ b/semestr-2/racket/l11z20/compiled/drracket/errortrace/graph_rkt.dep @@ -0,0 +1 @@ +("7.6" racket ("b51d3a36a64d34c7978bfc22f2a5fe674cee1cb6" . "8314027ed4c1c6fd9c412af77103e94790e59dd2") (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt")) diff --git a/semestr-2/racket/l11z20/compiled/drracket/errortrace/graph_rkt.zo b/semestr-2/racket/l11z20/compiled/drracket/errortrace/graph_rkt.zo Binary files differnew file mode 100644 index 0000000..ef91f9a --- /dev/null +++ b/semestr-2/racket/l11z20/compiled/drracket/errortrace/graph_rkt.zo diff --git a/semestr-2/racket/l11z20/graph.bak b/semestr-2/racket/l11z20/graph.bak new file mode 100644 index 0000000..9f4d79d --- /dev/null +++ b/semestr-2/racket/l11z20/graph.bak @@ -0,0 +1,97 @@ +#lang racket + +(provide bag^ graph^ simple-graph@ graph-search^ graph-search@) + +;; sygnatura dla struktury danych +(define-signature bag^ + ((contracted + [bag? (-> any/c boolean?)] + [empty-bag (and/c bag? bag-empty?)] + [bag-empty? (-> bag? boolean?)] + [bag-insert (-> bag? any/c (and/c bag? (not/c bag-empty?)))] + [bag-peek (-> (and/c bag? (not/c bag-empty?)) any/c)] + [bag-remove (-> (and/c bag? (not/c bag-empty?)) bag?)]))) + +;; sygnatura: grafy +(define-signature graph^ + ((contracted + [graph (-> list? (listof edge?) graph?)] + [graph? (-> any/c boolean?)] + [graph-nodes (-> graph? list?)] + [graph-edges (-> graph? (listof edge?))] + [edge (-> any/c any/c edge?)] + [edge? (-> any/c boolean?)] + [edge-start (-> edge? any/c)] + [edge-end (-> edge? any/c)] + [has-node? (-> graph? any/c boolean?)] + [outnodes (-> graph? any/c list?)] + [remove-node (-> graph? any/c graph?)] + ))) + +;; prosta implementacja grafów +(define-unit simple-graph@ + (import) + (export graph^) + + (define (graph? g) + (and (list? g) + (eq? (length g) 3) + (eq? (car g) 'graph))) + + (define (edge? e) + (and (list? e) + (eq? (length e) 3) + (eq? (car e) 'edge))) + + (define (graph-nodes g) (cadr g)) + + (define (graph-edges g) (caddr g)) + + (define (graph n e) (list 'graph n e)) + + (define (edge n1 n2) (list 'edge n1 n2)) + + (define (edge-start e) (cadr e)) + + (define (edge-end e) (caddr e)) + + (define (has-node? g n) (not (not (member n (graph-nodes g))))) + + (define (outnodes g n) + (filter-map + (lambda (e) + (and (eq? (edge-start e) n) + (edge-end e))) + (graph-edges g))) + + (define (remove-node g n) + (graph + (remove n (graph-nodes g)) + (filter + (lambda (e) + (not (eq? (edge-start e) n))) + (graph-edges g))))) + +;; sygnatura dla przeszukiwania grafu +(define-signature graph-search^ + (search)) + +;; implementacja przeszukiwania grafu +;; uzależniona od implementacji grafu i struktury danych +(define-unit graph-search@ + (import bag^ graph^) + (export graph-search^) + (define (search g n) + (define (it g b l) + (cond + [(bag-empty? b) (reverse l)] + [(has-node? g (bag-peek b)) + (it (remove-node g (bag-peek b)) + (foldl + (lambda (n1 b1) (bag-insert b1 n1)) + (bag-remove b) + (outnodes g (bag-peek b))) + (cons (bag-peek b) l))] + [else (it g (bag-remove b) l)])) + (it g (bag-insert empty-bag n) '())) + ) diff --git a/semestr-2/racket/l11z20/graph.rkt b/semestr-2/racket/l11z20/graph.rkt new file mode 100644 index 0000000..ec19576 --- /dev/null +++ b/semestr-2/racket/l11z20/graph.rkt @@ -0,0 +1,100 @@ +#lang racket + +(provide bag^ graph^ simple-graph@ graph-search^ graph-search@) + +;; sygnatura dla struktury danych +(define-signature bag^ + ((contracted + [bag? (-> any/c boolean?)] + [empty-bag (and/c bag? bag-empty?)] + [bag-empty? (-> bag? boolean?)] + [bag-insert (-> bag? any/c (and/c bag? (not/c bag-empty?)))] + [bag-peek (-> (and/c bag? (not/c bag-empty?)) any/c)] + [bag-remove (-> (and/c bag? (not/c bag-empty?)) bag?)]))) + +;; sygnatura: grafy +(define-signature graph^ + ((contracted + [graph (-> list? (listof edge?) graph?)] + [graph? (-> any/c boolean?)] + [graph-nodes (-> graph? list?)] + [graph-edges (-> graph? (listof edge?))] + [edge (-> any/c any/c edge?)] + [edge? (-> any/c boolean?)] + [edge-start (-> edge? any/c)] + [edge-end (-> edge? any/c)] + [has-node? (-> graph? any/c boolean?)] + [outnodes (-> graph? any/c list?)] + [remove-node (-> graph? any/c graph?)] + ))) + +;; prosta implementacja grafów +(define-unit simple-graph@ + (import) + (export graph^) + + (define (graph? g) + (and (list? g) + (eq? (length g) 3) + (eq? (car g) 'graph))) + + (define (edge? e) + (and (list? e) + (eq? (length e) 3) + (eq? (car e) 'edge))) + + (define (graph-nodes g) (cadr g)) + + (define (graph-edges g) (caddr g)) + + (define (graph n e) (list 'graph n e)) + + (define (edge n1 n2) (list 'edge n1 n2)) + + (define (edge-start e) (cadr e)) + + (define (edge-end e) (caddr e)) + + (define (has-node? g n) (not (not (member n (graph-nodes g))))) + + (define (outnodes g n) + (filter-map + (lambda (e) + (and (eq? (edge-start e) n) + (edge-end e))) + (graph-edges g))) + + (define (remove-node g n) + (graph + (remove n (graph-nodes g)) + (filter + (lambda (e) + (not (eq? (edge-start e) n))) + (graph-edges g))))) + +;; sygnatura dla przeszukiwania grafu +(define-signature graph-search^ + (search)) + +;; implementacja przeszukiwania grafu +;; uzależniona od implementacji grafu i struktury danych +(define-unit graph-search@ + (import bag^ graph^) + (export graph-search^) + (define (search g n) + (define (it g b l) + (cond + [(bag-empty? b) (reverse l)] + [(has-node? g (bag-peek b)) + (it (remove-node g (bag-peek b)) + (foldl + (lambda (n1 b1) (bag-insert b1 n1)) + (bag-remove b) + (outnodes g (bag-peek b))) + (cons (bag-peek b) l))] + [else (it g (bag-remove b) l)])) + (it g (bag-insert empty-bag n) '())) + ) + +;; otwarcie komponentu grafu +(define-values/invoke-unit/infer simple-graph@)
\ No newline at end of file diff --git a/semestr-2/racket/l11z20/solution.bak b/semestr-2/racket/l11z20/solution.bak new file mode 100644 index 0000000..6f1f7b4 --- /dev/null +++ b/semestr-2/racket/l11z20/solution.bak @@ -0,0 +1 @@ +#lang racket diff --git a/semestr-2/racket/l11z20/solution.rkt b/semestr-2/racket/l11z20/solution.rkt new file mode 100644 index 0000000..e3ad81f --- /dev/null +++ b/semestr-2/racket/l11z20/solution.rkt @@ -0,0 +1,245 @@ +#lang racket + +(require "graph.rkt") +(provide bag-stack@ bag-fifo@) + +;; struktura danych - stos +(define-unit bag-stack@ + (import) + (export bag^) + + (define (bag? b) + (and (cons? b) + (eq? (car b) 'stack))) + + (define empty-bag (cons 'stack null)) + + (define (bag-empty? b) + (null? (cdr b))) + + (define (bag-insert b val) + (cons 'stack (cons val (cdr b)))) + + (define (bag-peek b) + (cadr b)) + + (define (bag-remove b) + (cons 'stack (cddr b))) +) + +;; struktura danych - kolejka FIFO +(define-unit bag-fifo@ + (import) + (export bag^) + + (define (bag? b) + (and (list? b) + (eq? (length b) 3) + (eq? (first b) 'queue))) + + (define empty-bag + (list 'queue null null)) + + (define (bag-empty? b) + (and (null? (second b)) (null? (third b)))) + + (define (bag-insert b val) + (list 'queue (cons val (second b)) (third b))) + + (define (bag-peek b) + (let ((insq (second b)) + (popq (third b))) + (cond + [(null? popq) (last insq)] + [else (first popq)]))) + + (define (bag-remove b) + (let ((insq (second b)) + (popq (third b))) + (cond + [(null? popq) (list 'queue null (cdr (reverse insq)))] + [else (list 'queue insq (cdr popq))]))) +) + +;; otwarcie komponentów stosu i kolejki + +(define-values/invoke-unit bag-stack@ + (import) + (export (prefix stack: bag^))) + +(define-values/invoke-unit bag-fifo@ + (import) + (export (prefix fifo: bag^))) + +;; testy w Quickchecku +(require quickcheck) + +;; liczba zapytań na test quickchecka +(define TESTS 1000) + + +;; TESTY DO KOLEJKI + +;; xs to lista jakichś liczb, queries to rodzaj wykonywanych operacji +;; 0 - popuje na listę pops +;; 1 - insertuje na queue +;; jest nie ma nic na kolejce/stosie i dostajemy 0, to nic nie robimy +;; jesli queries albo xs są puste to po prostu kończymy obsługiwanie zapytań +;; na koncu sprawdzamy, czy (reverse pops) jest prefiksem xs + + +(define (check-queue xs queries) + (define (iter xs queries queue pops) + ;; (display queue) + ;; (newline) + (if (or (null? queries) (null? xs)) + (reverse pops) + (cond + [(and (eq? (car queries) 0) (not (fifo:bag-empty? queue))) + (iter xs (cdr queries) (fifo:bag-remove queue) (cons (fifo:bag-peek queue) pops))] + [else (iter (cdr xs) (cdr queries) (fifo:bag-insert queue (car xs)) pops)]))) + (define (is-prefix? xs ys) + (if (null? xs) + #t + (and (equal? (car xs) (car ys)) (is-prefix? (cdr xs) (cdr ys))))) + (is-prefix? (iter xs queries fifo:empty-bag null) xs)) + +;; sprawdzenie czy nasza funkcja testująca w ogóle działa +(define check-queue-test (lambda () (check-queue (list 1 2 3 4 5 6 7 8) (list 0 1 1 1 0 0 0 1 1 0 1 0 1 0 0)))) + +;; testowanie kolejki +(define-unit queue-tests@ + (import bag^) + (export) + + (quickcheck + (property ([xs (choose-list (choose-real -100000 100000) TESTS)] + [ops (choose-list (choose-integer 0 1) TESTS)]) + (check-queue xs ops)))) + +(invoke-unit queue-tests@ (import (prefix fifo: bag^))) + + +;; TESTY DO STOSU + +;; niestety tutaj nie jest tak kolorowo, na kolejce +;; dokładnie wiemy jaka jest koljeność popowanych, na stosie to dosyć dowolne. +;; Z drugiej strony jego implementacja jest dużo prostsza, więc testy też nie muszą +;; być bardzo rygorystyczne. + +(define (check-stack xs) + (define (insert-list stack xs) + (if (null? xs) + stack + (insert-list (stack:bag-insert stack (car xs)) (cdr xs)))) + (define (clear-stack stack pops) + (if (stack:bag-empty? stack) + pops + (clear-stack (stack:bag-remove stack) (cons (stack:bag-peek stack) pops)))) + (equal? xs (clear-stack (insert-list stack:empty-bag xs) null))) + + +;; testowanie stacka +(define-unit stack-tests@ + (import bag^) + (export) + (quickcheck + (property ([xs (choose-list (choose-real -100000 100000) TESTS)]) + (check-stack xs)))) + +(invoke-unit stack-tests@ (import (prefix stack: bag^))) + + + +;; testy kolejek i stosów +(define-unit bag-tests@ + (import bag^) + (export) + + ;; test przykładowy: jeśli do pustej struktury dodamy element + ;; i od razu go usuniemy, wynikowa struktura jest pusta + (quickcheck + (property ([s arbitrary-symbol]) + (bag-empty? (bag-remove (bag-insert empty-bag s))))) + + ;; Sprawdzenie własności wspólnych dla obu struktur + (quickcheck + (property ([s arbitrary-symbol]) + (equal? s (bag-peek (bag-insert empty-bag s))))) +) + +;; uruchomienie testów dla obu struktur danych + +(invoke-unit bag-tests@ (import (prefix stack: bag^))) +(invoke-unit bag-tests@ (import (prefix fifo: bag^))) + + + +;; TESTOWANIE PRZESZUKIWAŃ + +;; otwarcie komponentu grafu +(define-values/invoke-unit/infer simple-graph@) + +;; otwarcie komponentów przeszukiwania +;; w głąb i wszerz +(define-values/invoke-unit graph-search@ + (import graph^ (prefix stack: bag^)) + (export (prefix dfs: graph-search^))) + +(define-values/invoke-unit graph-search@ + (import graph^ (prefix fifo: bag^)) + (export (prefix bfs: graph-search^))) + +;; graf testowy +(define test-graph + (graph + (list 1 2 3 4) + (list (edge 1 3) + (edge 1 2) + (edge 2 4)))) + +(define test-graph2 + (graph (list 1) null)) + +(define test-graph3 + (graph (list 1 2 3 4 5 6 7 8 9 10) + (list (edge 1 2) + (edge 1 3) + (edge 2 3) + (edge 3 2) + (edge 3 5) + (edge 6 5) + (edge 5 7) + (edge 5 8) + (edge 7 9) + (edge 8 9) + (edge 9 10) + (edge 1 10) + (edge 10 1)))) + + +(define test-graph4 + (graph (list 1 2 3 4 5 6) + (list (edge 1 2) + (edge 2 3) + (edge 3 4) + (edge 4 5) + (edge 5 6)))) + +;; uruchomienie przeszukiwania na przykładowym grafie +(bfs:search test-graph 1) +(dfs:search test-graph 1) + +(bfs:search test-graph2 1) +(dfs:search test-graph2 1) + +(bfs:search test-graph3 1) +(dfs:search test-graph3 1) + +(bfs:search test-graph3 6) +(dfs:search test-graph3 6) + +(bfs:search test-graph4 1) +(dfs:search test-graph4 1) + + diff --git a/semestr-2/racket/l13/oceny.txt b/semestr-2/racket/l13/oceny.txt new file mode 100644 index 0000000..9f17cad --- /dev/null +++ b/semestr-2/racket/l13/oceny.txt @@ -0,0 +1,18 @@ +1 sem
+
+MDM - 5 5
+AO - 5
+AM 1 - 5 5
+LDI - 5 5
+MIA - 5
+
+8 * 5
+
+
+2 sem
+
+Topologia - 5 3
+Analiza - 4 4
+MP - 5 5
+PPS - 5
+Algebra - 5 5
\ No newline at end of file diff --git a/semestr-2/racket/l13/rozw.rkt b/semestr-2/racket/l13/rozw.rkt new file mode 100644 index 0000000..b4094db --- /dev/null +++ b/semestr-2/racket/l13/rozw.rkt @@ -0,0 +1,79 @@ +#lang typed/racket
+
+
+;;; zadanie 1
+
+(: prefixes (All (a) (-> (Listof a) (Listof (Listof a)))))
+(define (prefixes xs)
+ (if (null? xs)
+ (list null)
+ (cons xs (prefixes (cdr xs)))))
+
+
+
+;;; zadanie 2
+
+(struct vector2 ([x : Real] [y : Real]) #:transparent)
+(struct vector3 ([x : Real] [y : Real] [z : Real]) #:transparent)
+
+(define-type Vector (U vector2 vector3))
+(define-predicate vector? Vector)
+
+
+(: square (-> Real Nonnegative-Real))
+(define (square x)
+ (if (< x 0) (* x x) (* x x)))
+
+
+;;; pierwsza wersja
+
+(: vector-length (-> Vector Nonnegative-Real))
+(define (vector-length v)
+ (if (vector2? v)
+ (match v [(vector2 x y) (sqrt (+ (square x) (square y)))])
+ (match v [(vector3 x y z) (sqrt (+ (square x) (square y) (square z)))])))
+
+
+;;; druga wersja
+
+(: vector-length-match (-> Vector Nonnegative-Real))
+(define (vector-length-match v)
+ (match v
+ [(vector2 x y) (sqrt (+ (square x) (square y)))]
+ [(vector3 x y z) (sqrt (+ (square x) (square y) (square z)))]))
+
+
+
+;;; zadanie 4
+
+(struct leaf () #:transparent)
+(struct [a] node ([v : a] [xs : (Listof (Tree a))]) #:transparent)
+
+(define-type (Tree a) (node a))
+(define-predicate tree? (Tree Any))
+
+
+(: flat-map (All (a) (-> (-> (Tree a) (Listof a)) (Listof (Tree a)) (Listof a))))
+(define (flat-map f xs)
+ (if (null? xs)
+ null
+ (append (f (car xs)) (flat-map f (cdr xs)))))
+
+(: preorder (All (a) (-> (Tree a) (Listof a))))
+(define (preorder t)
+ (match t
+ [(node v xs)
+ (cons v (flat-map preorder xs))]))
+
+;;; (preorder (node 1 (list
+;;; (node 2 (list
+;;; (node 3 '())
+;;; (node 4 '())))
+;;; (node 5 '())
+;;; (node 'x (list
+;;; (node 't (list
+;;; (node 'z '()))))))))
+
+
+;;; zadanie 6
+
diff --git a/semestr-2/racket/l13/solution.rkt b/semestr-2/racket/l13/solution.rkt new file mode 100644 index 0000000..61804b3 --- /dev/null +++ b/semestr-2/racket/l13/solution.rkt @@ -0,0 +1,124 @@ +#lang typed/racket
+
+; --------- ;
+; Wyrazenia ;
+; --------- ;
+
+(provide parse typecheck)
+
+(define-type Expr (U const binop var-expr let-expr if-expr))
+(define-type Value (U Real Boolean))
+(define-type ArithOp (U '+ '- '/ '* '%))
+;;; (define-type ModOp '%)
+(define-type CompOp (U '= '> '>= '< '<=))
+(define-type LogicOp (U 'and 'or))
+(define-type BinopSym (U ArithOp CompOp LogicOp))
+
+(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 arith-op? ArithOp)
+;;; (define-predicate mod-op? ModOp)
+(define-predicate comp-op? CompOp)
+(define-predicate logic-op? LogicOp)
+(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)]))
+
+; ---------- ;
+; Srodowiska ;
+; ---------- ;
+
+(define-type EType (U 'real 'boolean))
+(define-predicate EType? EType)
+
+(struct environ ([xs : (Listof (Pairof Symbol EType))]))
+(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 EType))
+(define (env-lookup x env)
+ (: assoc-lookup (-> (Listof (Pairof Symbol EType)) 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)))
+
+(: check-op (-> Expr Expr EType EType environ (U EType #f)))
+(define (check-op e1 e2 arg-type ret-type env)
+ (if (and (eq? (typecheck-env e1 env) arg-type)
+ (eq? (typecheck-env e2 env) arg-type))
+ ret-type
+ #f))
+
+(: typecheck-env (-> Expr environ (U EType #f)))
+(define (typecheck-env e env)
+ (match e
+ [(const val)
+ (cond
+ [(real? val) 'real]
+ [(boolean? val) 'boolean])]
+ [(var-expr id) (env-lookup id env)]
+ [(binop op e1 e2)
+ (cond
+ [(arith-op? op) (check-op e1 e2 'real 'real env)]
+ [(comp-op? op) (check-op e1 e2 'real 'boolean env)]
+ [(logic-op? op) (check-op e1 e2 'boolean 'boolean env)])]
+ [(let-expr id e1 e2)
+ (let ((id-type (typecheck-env e1 env)))
+ (if id-type
+ (typecheck-env e2 (env-add id id-type env))
+ #f))]
+ [(if-expr eb et ef)
+ (let ((eb-type (typecheck-env eb env)))
+ (if (not (eq? eb-type 'boolean))
+ #f
+ (let ((et-type (typecheck-env et env))
+ (ef-type (typecheck-env ef env)))
+ (if (eq? et-type ef-type) ;;; nie trzeba sprawdzac czy ktores z nich to #f
+ et-type ;;; jesli tak jest, to i tak sie na pewno zwroci #f
+ #f))))]))
+
+(: typecheck (-> Expr (U EType #f)))
+(define (typecheck e)
+ (typecheck-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 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 diff --git a/semestr-2/racket/l14z22/solution.bak b/semestr-2/racket/l14z22/solution.bak new file mode 100644 index 0000000..0d4f164 --- /dev/null +++ b/semestr-2/racket/l14z22/solution.bak @@ -0,0 +1,70 @@ +#lang racket + +(require racklog) + +(provide solve) + +;; transpozycja tablicy zakodowanej jako lista list +(define (transpose xss) + (cond [(null? xss) xss] + ((null? (car xss)) (transpose (cdr xss))) + [else (cons (map car xss) + (transpose (map cdr xss)))])) + +;; procedura pomocnicza +;; tworzy listę n-elementową zawierającą wyniki n-krotnego +;; wywołania procedury f +(define (repeat-fn n f) + (if (eq? 0 n) null + (cons (f) (repeat-fn (- n 1) f)))) + +;; tworzy tablicę n na m elementów, zawierającą świeże +;; zmienne logiczne +(define (make-rect n m) + (repeat-fn m (lambda () (repeat-fn n _)))) + +;; predykat binarny +;; (%row-ok xs ys) oznacza, że xs opisuje wiersz (lub kolumnę) ys +(define %row-ok + (%rel () +;; TODO: uzupełnij! + )) + +;; TODO: napisz potrzebne ci pomocnicze predykaty + +;; funkcja rozwiązująca zagadkę +(define (solve rows cols) + (define board (make-rect (length cols) (length rows))) + (define tboard (transpose board)) + (define ret (%which (xss) + (%= xss board) +;; TODO: uzupełnij! + )) + (and ret (cdar ret))) + +;; testy +(equal? (solve '((2) (1) (1)) '((1 1) (2))) + '((* *) + (_ *) + (* _))) + +(equal? (solve '((2) (2 1) (1 1) (2)) '((2) (2 1) (1 1) (2))) + '((_ * * _) + (* * _ *) + (* _ _ *) + (_ * * _))) + +(equal? (solve '((4) (6) (2 2) (2 2) (6) (4) (2) (2) (2)) + '((9) (9) (2 2) (2 2) (4) (4))) + '((* * * * _ _) + (* * * * * *) + (* * _ _ * *) + (* * _ _ * *) + (* * * * * *) + (* * * * _ _) + (* * _ _ _ _) + (* * _ _ _ _) + (* * _ _ _ _))) + +;; TODO: możesz dodać własne testy + diff --git a/semestr-2/racket/l14z22/solution.rkt b/semestr-2/racket/l14z22/solution.rkt new file mode 100644 index 0000000..480c772 --- /dev/null +++ b/semestr-2/racket/l14z22/solution.rkt @@ -0,0 +1,87 @@ +#lang racket + +(require racklog) + +(provide solve) + +;; transpozycja tablicy zakodowanej jako lista list +(define (transpose xss) + (cond [(null? xss) xss] + ((null? (car xss)) (transpose (cdr xss))) + [else (cons (map car xss) + (transpose (map cdr xss)))])) + +;; procedura pomocnicza +;; tworzy listę n-elementową zawierającą wyniki n-krotnego +;; wywołania procedury f +(define (repeat-fn n f) + (if (eq? 0 n) null + (cons (f) (repeat-fn (- n 1) f)))) + +;; tworzy tablicę n na m elementów, zawierającą świeże +;; zmienne logiczne +(define (make-rect n m) + (repeat-fn m (lambda () (repeat-fn n _)))) + +;; predykat binarny +;; (%row-ok xs ys) oznacza, że xs opisuje wiersz (lub kolumnę) ys +(define %row-ok + (%rel (xs ys zs n) + [(null null)] + [(xs (cons '_ ys)) + (%row-ok xs ys)] + [((cons n xs) ys) + (%stars ys n) + (%cut-first-n ys zs n) + (%row-ok xs zs)])) + + +(define %suffix + (%rel (xs ys x) + [(xs xs)] + [((cons x xs) ys) + (%suffix xs ys)])) + +(define %cut-first-n + (%rel (xs ys n yl) + [(xs xs 0)] + [(xs ys n) + (%suffix xs ys) + (%is #t (= (- (length xs) (length ys)) n))])) + + +;; usun n pierwszych elementow z xs +(define (suffix xs n) + (if (= n 0) + xs + (suffix (cdr xs) (- n 1)))) + + +;; sprawdza czy pierwsze n elementów listy to gwiazdki (dokladnie n) +(define %stars + (%rel (xs m n) + [(null 0)] + [((cons '_ xs) n) + (%is n 0)] + [((cons '* xs) n) + (%is m (- n 1)) + (%stars xs m)])) + +(define %board-ok + (%rel (xss xs yss ys) + [(null null)] + [((cons xs xss) (cons ys yss)) + (%row-ok xs ys) + (%board-ok xss yss)])) + +;; funkcja rozwiązująca zagadkę +(define (solve rows cols) + (define board (make-rect (length cols) (length rows))) + (define tboard (transpose board)) + (define ret (%which (xss) + (%= xss board) + (%board-ok rows board) + (%board-ok cols tboard))) + (and ret (cdar ret))) + + diff --git a/semestr-2/racket/l15/kacp.bak b/semestr-2/racket/l15/kacp.bak new file mode 100644 index 0000000..ff2a2bc --- /dev/null +++ b/semestr-2/racket/l15/kacp.bak @@ -0,0 +1,55 @@ +#lang racket + +(define (run-concurrent . thunks) + (define threads (map thread thunks)) + (for-each thread-wait threads)) + +(define (random-sleep) + (sleep (/ (random) 100))) + +(define (with-random-sleep proc) + (lambda args + (random-sleep) + (apply proc args))) + +(define (make-serializer) + (define sem (make-semaphore 1)) + (lambda (proc) + (lambda args + (semaphore-wait sem) + (define ret (apply proc args)) + (semaphore-post sem) + ret))) + +(define (table) + (random-sleep) + (define forks (list (make-semaphore 1) + (make-semaphore 1) + (make-semaphore 1) + (make-semaphore 1) + (make-semaphore 1))) + (define (pick-fork i) + (random-sleep) + (semaphore-wait (list-ref forks i))) + (define (put-fork i) + (random-sleep) + (semaphore-post (list-ref forks i))) + (define (dispatch m) + (cond [(eq? m 'pick-fork) pick-fork] + [(eq? m 'put-fork) put-fork] + [else (error "Unknown request -- TABLE" + m)])) + dispatch) + +(define dtable (table)) + +(define (philosopher dining-table number) + (define my-turn (make-serializer)) + (define (eat) + (display number) + (newline) + ((dining-table 'pick-fork) number) + ((dining-table 'put-fork) number) + ((dining-table 'pick-fork) (modulo (+ number 1) 5)) + ((dining-table 'put-fork) (modulo (+ number 1) 5))) + (my-turn eat))
\ No newline at end of file diff --git a/semestr-2/racket/l15/kacp.rkt b/semestr-2/racket/l15/kacp.rkt new file mode 100644 index 0000000..bd484f1 --- /dev/null +++ b/semestr-2/racket/l15/kacp.rkt @@ -0,0 +1,59 @@ +#lang racket + +(define (run-concurrent . thunks) + (define threads (map thread thunks)) + (for-each thread-wait threads)) + +(define (random-sleep) + (sleep (/ (random) 100))) + +(define (with-random-sleep proc) + (lambda args + (random-sleep) + (apply proc args))) + +(define (make-serializer) + (define sem (make-semaphore 1)) + (lambda (proc) + (lambda args + (semaphore-wait sem) + (define ret (apply proc args)) + (semaphore-post sem) + ret))) + +(define (table) + (random-sleep) + (define forks (list (make-semaphore 1) + (make-semaphore 1) + (make-semaphore 1) + (make-semaphore 1) + (make-semaphore 1))) + (define (pick-fork i) + (random-sleep) + (semaphore-wait (list-ref forks i))) + (define (put-fork i) + (random-sleep) + (semaphore-post (list-ref forks i))) + (define (dispatch m) + (cond [(eq? m 'pick-fork) pick-fork] + [(eq? m 'put-fork) put-fork] + [else (error "Unknown request -- TABLE" + m)])) + dispatch) + +(define dtable (table)) + +(define (philosopher dining-table number) + (define my-turn (make-serializer)) + (define (eat) + (display "Zaczynam ") + (display number) + (newline) + ((dining-table 'pick-fork) number) + ((dining-table 'put-fork) number) + ((dining-table 'pick-fork) (modulo (+ number 1) 5)) + ((dining-table 'put-fork) (modulo (+ number 1) 5)) + (display "Koncze ") + (display number) + (newline)) + (my-turn eat))
\ No newline at end of file diff --git a/semestr-2/racket/l15/solution.bak b/semestr-2/racket/l15/solution.bak new file mode 100644 index 0000000..03ab86a --- /dev/null +++ b/semestr-2/racket/l15/solution.bak @@ -0,0 +1,7 @@ +#lang racket + + + +(define (run-concurrent . thunks) + (define threads (map thread thunks)) + (for-each thread-wait threads))
\ No newline at end of file diff --git a/semestr-2/racket/l15/solution.rkt b/semestr-2/racket/l15/solution.rkt new file mode 100644 index 0000000..915502e --- /dev/null +++ b/semestr-2/racket/l15/solution.rkt @@ -0,0 +1,85 @@ +#lang racket + +(provide philosopher) + +;; Do debugu + +(define (run-concurrent . thunks) + (define threads (map thread thunks)) + (for-each thread-wait threads)) + +(define (random-sleep) + (sleep (/ (random) 100))) + +(define (with-random-sleep proc) + (lambda args + (random-sleep) + (apply proc args))) + +(define (make-serializer) + (define sem (make-semaphore 1)) + (lambda (proc) + (lambda args + (semaphore-wait sem) + (define ret (apply proc args)) + (semaphore-post sem) + ret))) + +(define (make-table) + (define forks (map (lambda (x) (make-semaphore 1)) '(0 1 2 3 4))) + (define (get-fork i) + (list-ref forks i)) + (define (pick-fork i) + (random-sleep) + (semaphore-wait (get-fork i))) + (define (put-fork i) + (random-sleep) + (semaphore-post (get-fork i))) + (define (dispatch m) + (cond [(eq? m 'pick-fork) pick-fork] + [(eq? m 'put-fork) put-fork] + [else (error "Unknown request -- MAKE-TABLE" m)])) + dispatch) + +;(define dining-table (make-table)) + +;(define (repeat proc n) +; (if (> n 0) +; (begin +; (proc) +; (repeat proc (- n 1))) +; #f)) +; +;(define (hungry nr x) +; (lambda () (repeat (lambda () (philosopher dining-table nr)) x))) + +;; Rozwiązanie: + +(define forks-sem (map (lambda (x) (make-semaphore 1)) '(0 0 0 0 0))) + +(define (get-fork i) + (list-ref forks-sem i)) + +(define (is-free? i) + (semaphore-try-wait? (get-fork i))) + +(define (put-fork dining-table i) + ((dining-table 'put-fork) i) + (semaphore-post (get-fork i))) + +(define (philosopher dining-table i) + (define left-fork i) + (define right-fork (modulo (+ i 1) 5)) + (define (loop) + (if (is-free? left-fork) + (if (is-free? right-fork) + (begin + ((dining-table 'pick-fork) left-fork) + ((dining-table 'pick-fork) right-fork) + (put-fork dining-table left-fork) + (put-fork dining-table right-fork)) + (loop)) + (begin + (semaphore-post (get-fork left-fork)) + (loop)))) + (loop))
\ No newline at end of file diff --git a/semestr-2/racket/l7z12/solution.rkt b/semestr-2/racket/l7z12/solution.rkt new file mode 100644 index 0000000..089dee4 --- /dev/null +++ b/semestr-2/racket/l7z12/solution.rkt @@ -0,0 +1,95 @@ +#lang racket
+
+(provide (struct-out const)
+ (struct-out binop)
+ (struct-out var-expr)
+ (struct-out let-expr)
+ (struct-out pos)
+ (struct-out var-free)
+ (struct-out var-bound)
+ annotate-expression)
+
+;; ---------------
+;; Jezyk wejsciowy
+;; ---------------
+
+(struct pos (file line col) #:transparent)
+
+(struct const (val) #:transparent)
+(struct binop (op l r) #:transparent)
+(struct var-expr (id) #:transparent)
+(struct let-expr (loc 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)]
+ [(let-expr loc x e1 e2)
+ (and (pos? loc) (symbol? x) (expr? e1) (expr? e2))]
+ [_ false]))
+
+(define (make-pos s)
+ (pos (syntax-source s)
+ (syntax-line s)
+ (syntax-column s)))
+
+(define (parse e)
+ (let ([r (syntax-e e)])
+ (cond
+ [(number? r) (const r)]
+ [(symbol? r) (var-expr r)]
+ [(and (list? r) (= 3 (length r)))
+ (match (syntax-e (car r))
+ ['let (let* ([e-def (syntax-e (second r))]
+ [x (syntax-e (first e-def))])
+ (let-expr (make-pos (first e-def))
+ (if (symbol? x) x (error "parse error!"))
+ (parse (second e-def))
+ (parse (third r))))]
+ [op (binop op (parse (second r)) (parse (third r)))])]
+ [else (error "parse error!")])))
+
+;; ---------------
+;; Jezyk wyjsciowy
+;; ---------------
+
+(struct var-free (id) #:transparent)
+(struct var-bound (pos id) #:transparent)
+
+(define (expr-annot? e)
+ (match e
+ [(const n) (number? n)]
+ [(binop op l r) (and (symbol? op) (expr-annot? l) (expr-annot? r))]
+ [(var-free x) (symbol? x)]
+ [(var-bound loc x) (and (pos? loc) (symbol? x))]
+ [(let-expr loc x e1 e2)
+ (and (pos? loc) (symbol? x) (expr-annot? e1) (expr-annot? e2))]
+ [_ false]))
+
+(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) false]
+ [(eq? x (car (car xs))) (cdr (car xs))]
+ [else (assoc-lookup (cdr xs))]))
+ (assoc-lookup (environ-xs env)))
+
+(define (annotate-expression-env e env)
+ (match e
+ [(const r) (const r)]
+ [(binop op l r) (binop op (annotate-expression-env l env) (annotate-expression-env r env))]
+ [(var-expr x) (let ((pos (env-lookup x env)))
+ (if pos
+ (var-bound pos x)
+ (var-free x)))]
+ [(let-expr loc x e1 e2) (let-expr loc x (annotate-expression-env e1 env) (annotate-expression-env e2 (env-add x loc env)))]))
+
+(define (annotate-expression e)
+ (annotate-expression-env e env-empty))
+
+(define (test) (annotate-expression (parse #'(let [x 5] (let [x (* x y)] (+ x y))))))
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 diff --git a/semestr-2/racket/l8z14/solution.bak b/semestr-2/racket/l8z14/solution.bak new file mode 100644 index 0000000..b51383a --- /dev/null +++ b/semestr-2/racket/l8z14/solution.bak @@ -0,0 +1,155 @@ +#lang racket + +; Do list.rkt dodajemy procedury +; +; 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 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) ; <------------------ !!! + +(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))] + [(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))] ; <----------------- !!! + [_ 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? (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) 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 environ (xs) #:transparent) + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; 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))) ; <---------------------------------------------- !!! + +(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] + [(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))] + [(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 + '(let [twice (lambda (f x) (f (f x)))] + (let [inc (lambda (x) (+ 1 x))] + (twice twice twice twice inc 1)))) + + +(define (test-eval) (eval (parse program)))
\ No newline at end of file diff --git a/semestr-2/racket/l8z14/solution.rkt b/semestr-2/racket/l8z14/solution.rkt new file mode 100644 index 0000000..59556cf --- /dev/null +++ b/semestr-2/racket/l8z14/solution.rkt @@ -0,0 +1,201 @@ +#lang racket + +; Do list.rkt dodajemy procedury +; +; Miejsca, ktore sie zmienily oznaczone sa przez !!! + +; --------- ; +; Wyrazenia ; +; --------- ; + +(provide eval parse) + + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) +(struct var-expr (id) #:transparent) +(struct let-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 apply-expr (f xs) #: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))] + [(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))] ; <----------------- !!! + [(apply-expr f xs) (and (expr? f) (expr? xs))] + [_ 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 (> (length q) 0) (list? q) (eq? (first q) 'list)) + (parse-list (cdr 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) 'apply)) + (apply-expr (parse (second q)) + (parse (third 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) 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))])) + +(define (parse-list q) + (if (null? q) + (null-expr) + (cons-expr (parse (car q)) (parse-list (cdr q))))) + +; ---------- ; +; Srodowiska ; +; ---------- ; + +(struct environ (xs) #:transparent) + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; 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))) ; <---------------------------------------------- !!! + +(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] + [(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))] + [(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))] + [(apply-expr e1 e2) + (let ([xs (eval-env e2 env)]) + (eval-env (eval-apply e1 (reverse xs)) 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-apply e xs) + (if (null? xs) + e + (app (eval-apply e (cdr xs)) (const (car xs))))) + +(define (eval e) (eval-env e env-empty)) + +;; testy wspólnie z Karolem Ochmanem + +(define program1 + '(apply (lambda (x y) (+ x y)) + (cons 1 (cons 2 null)))) +(define program2 + '(apply (lambda (x y z) (+ x (+ y z))) + (cons 1 (cons 2 null)))) +(define program3 + '(apply (lambda (x y) (lambda (z) (+ x (+ y z)))) + (cons 1 (cons 2 (cons 3 null))))) +(define program4 + '(apply (lambda (x y) (+ x y)) + (cons 1 (cons 2 (cons 3 null))))) +(define program5 + '(let [f (lambda (x y z) (+ z (+ x y)))] + (apply (f 3) (cons 1 (cons 2 null))))) +(define program6 + '(let [f (lambda (x) x)] + (apply (f 4) null))) +(define program7 + '(apply (lambda (q w e r t y u i o p a s d f g h j k l) 3) + (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 + (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 + (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 null))))))))))))))))))))) +(define program8 + '(apply (lambda (q w e r t y u i o p a s d f g h j k l) 3) + (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 (cons 1 + (cons 1 (cons 1 (cons 1 (cons 1 null)))))))))))))))
\ No newline at end of file diff --git a/semestr-2/racket/l8z15/solution.bak b/semestr-2/racket/l8z15/solution.bak new file mode 100644 index 0000000..cdc84f9 --- /dev/null +++ b/semestr-2/racket/l8z15/solution.bak @@ -0,0 +1,187 @@ +#lang racket
+
+; Do list.rkt dodajemy procedury
+;
+; Miejsca, ktore sie zmienily oznaczone sa przez !!!
+
+(provide parse eval)
+
+; --------- ;
+; Wyrazenia ;
+; --------- ;
+
+(struct const (val) #:transparent)
+(struct binop (op l r) #:transparent)
+(struct var-expr (id) #:transparent)
+(struct let-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) ; <------------------ !!!
+
+(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))]
+ [(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))] ; <----------------- !!!
+ [_ 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? (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) 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 environ (xs) #:transparent)
+
+(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 "Unknown identifier" x)]
+ [(eq? x (car (car xs))) (cdr (car xs))]
+ [else (assoc-lookup (cdr xs))]))
+ (assoc-lookup (environ-xs env)))
+
+; --------- ;
+; Ewaluacja ;
+; --------- ;
+
+(struct clo (id e env) #:transparent) ; <------------------------- !!!
+(struct odr (e env) #:transparent)
+
+(define (value? v)
+ (or (number? v)
+ (boolean? v)
+ (and (pair? v) (value? (car v)) (value? (cdr v)))
+ (null? v)
+ (clo? 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]
+ [(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) (match (env-lookup x env)
+ [(odr e env) (eval-env e env)]
+ [f f])]
+ [(if-expr eb et ef) (if (eval-env eb env)
+ (eval-env et env)
+ (eval-env ef env))]
+ [(cons-expr e1 e2) (cons (odr e1 env)
+ (odr e2 env))]
+ [(car-expr e) (let ([p (eval-env e env)])
+ (match (car p)
+ [(odr e env) (eval-env e env)]))]
+ [(cdr-expr e) (let ([p (eval-env e env)])
+ (match (cdr p)
+ [(odr e env) (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 (odr 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
+ '(let [twice (lambda (f x) (f (f x)))]
+ (let [inc (lambda (x) (+ 1 x))]
+ (twice twice twice twice inc 1))))
+
+
+;;; Testy wspólnie z Karolem Ochmanem
+
+(define (test-eval program) (eval (parse program)))
+
+(define program1
+ '((lambda (x) (+ 3 3)) (/ 5 0)))
+(define program2
+ '(let [if-fun (lambda (b t e) (if b t e))]
+ (if-fun true 4 (/ 5 0))))
+(define program3
+ '(car (cdr (cons 1 (cons 2 (cons 3 (cons 4 null)))))))
+(define program4
+ '(car (cons (+ 3 4) (/ 5 0))))
+(define program5
+ '(cons (+ 5 6) (- 4 3)))
+(define program6
+ '(car (cdr (cdr (car (cons (cons (/ 0 0) (cons (/ 0 0) (cons 1 (/ 0 0)))) (cdr (cons (/ 0 0) null))))))))
+;;; (test-eval program)
+;;; (test-eval program1)
+;;; (test-eval program2)
+;;; (test-eval program3)
+;;; (test-eval program4)
+;;; (test-eval program5)
+;;; (test-eval program6)
\ No newline at end of file diff --git a/semestr-2/racket/l8z15/solution.rkt b/semestr-2/racket/l8z15/solution.rkt new file mode 100644 index 0000000..54b6cd3 --- /dev/null +++ b/semestr-2/racket/l8z15/solution.rkt @@ -0,0 +1,182 @@ +#lang racket
+
+; Do list.rkt dodajemy procedury
+;
+; Miejsca, ktore sie zmienily oznaczone sa przez !!!
+
+(provide parse eval)
+
+; --------- ;
+; Wyrazenia ;
+; --------- ;
+
+(struct const (val) #:transparent)
+(struct binop (op l r) #:transparent)
+(struct var-expr (id) #:transparent)
+(struct let-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) ; <------------------ !!!
+
+(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))]
+ [(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))] ; <----------------- !!!
+ [_ 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? (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) 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 environ (xs) #:transparent)
+
+(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 "Unknown identifier" x)]
+ [(eq? x (car (car xs))) (cdr (car xs))]
+ [else (assoc-lookup (cdr xs))]))
+ (assoc-lookup (environ-xs env)))
+
+; --------- ;
+; Ewaluacja ;
+; --------- ;
+
+(struct clo (id e env) #:transparent) ; <------------------------- !!!
+(struct odr (e env) #:transparent)
+
+(define (value? v)
+ (or (number? v)
+ (boolean? v)
+ (and (pair? v) (value? (car v)) (value? (cdr v)))
+ (null? v)
+ (clo? 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]
+ [(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) (match (env-lookup x env)
+ [(odr e env) (eval-env e env)]
+ [f f])]
+ [(if-expr eb et ef) (if (eval-env eb env)
+ (eval-env et env)
+ (eval-env ef env))]
+ [(cons-expr e1 e2) (cons (odr e1 env)
+ (odr e2 env))]
+ [(car-expr e) (let ([p (eval-env e env)])
+ (match (car p)
+ [(odr e env) (eval-env e env)]))]
+ [(cdr-expr e) (let ([p (eval-env e env)])
+ (match (cdr p)
+ [(odr e env) (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 (odr 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))
+
+
+;;; Testy wspólnie z Karolem Ochmanem
+
+(define (test-eval program) (eval (parse program)))
+
+(define program1
+ '((lambda (x) (+ 3 3)) (/ 5 0)))
+(define program2
+ '(let [if-fun (lambda (b t e) (if b t e))]
+ (if-fun true 4 (/ 5 0))))
+(define program3
+ '(car (cdr (cons 1 (cons 2 (cons 3 (cons 4 null)))))))
+(define program4
+ '(car (cons (+ 3 4) (/ 5 0))))
+(define program5
+ '(cons (+ 5 6) (- 4 3)))
+(define program6
+ '(car (cdr (cdr (car (cons (cons (/ 0 0) (cons (/ 0 0) (cons 1 (/ 0 0)))) (cdr (cons (/ 0 0) null))))))))
+;;; (test-eval program)
+;;; (test-eval program1)
+;;; (test-eval program2)
+;;; (test-eval program3)
+;;; (test-eval program4)
+;;; (test-eval program5)
+;;; (test-eval program6)
\ No newline at end of file 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 diff --git a/semestr-2/racket/l9z16/solution.rkt b/semestr-2/racket/l9z16/solution.rkt new file mode 100644 index 0000000..0af169d --- /dev/null +++ b/semestr-2/racket/l9z16/solution.rkt @@ -0,0 +1,42 @@ +#lang racket
+
+(provide lcons lnull lnull? lcar lcdr)
+
+
+(define (lcons x f) (mcons x f))
+
+(define lnull null)
+
+(define lnull? null?)
+
+(define (lcar xs) (mcar xs))
+
+(define (lcdr xs)
+ (let ([x (mcdr xs)])
+ (cond [(not (mpair? x)) (set-mcdr! xs (x))]))
+ (mcdr xs))
+
+(define (from n)
+ (lcons n (lambda () (from (+ n 1)))))
+
+(define nats
+ (from 0))
+
+(define (lnth n xs)
+ (cond [(= n 0) (lcar xs)]
+ [else (lnth (- n 1) (lcdr xs))]))
+
+(define (lfilter p xs)
+ (cond [(lnull? xs) lnull]
+ [(p (lcar xs))
+ (lcons (lcar xs) (lambda () (lfilter p (lcdr xs))))]
+ [else (lfilter p (lcdr xs))]))
+
+(define (prime? n)
+ (define (factors i)
+ (cond [(>= i n) (list n)]
+ [(= (modulo n i) 0) (cons i (factors (+ i 1)))]
+ [else (factors (+ i 1))]))
+ (= (length (factors 1)) 2))
+
+(define primes (lfilter prime? (from 2)))
\ No newline at end of file diff --git a/semestr-2/racket/l9z17/solution.rkt b/semestr-2/racket/l9z17/solution.rkt new file mode 100644 index 0000000..5e98036 --- /dev/null +++ b/semestr-2/racket/l9z17/solution.rkt @@ -0,0 +1,266 @@ +#lang racket
+
+; Do programming.rkt dodajemy instrukcje
+
+(provide eval-while parse-while env-empty env-lookup)
+
+;;; We współpracy z Kacprem Soleckim
+
+; --------- ;
+; 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)
+
+(define (expr? e)
+ (match e
+ [(const n) (or (number? n) (boolean? n) (string? 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))]
+ [_ false]))
+
+(define (parse q)
+ (cond
+ [(number? q) (const q)]
+ [(eq? q 'true) (const true)]
+ [(eq? q 'false) (const false)]
+ [(eq? q 'null) (null-expr)]
+ [(string? q) (const q)]
+ [(symbol? q) (var-expr 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)))
+(define (env-update x v xs) ; <---------------------------------- !!!
+ (define (assoc-update xs)
+ (cond [(null? xs) (list (mcons x v))]
+ [(eq? x (mcar (car xs))) (cons (mcons x v) (cdr xs))]
+ [else (cons (car xs) (assoc-update (cdr xs)))]))
+ (environ (assoc-update (environ-xs xs))))
+
+; --------- ;
+; Ewaluacja ;
+; --------- ;
+
+(struct clo (id e env) #:transparent)
+(struct let-var (v) #:transparent)
+
+(define (value? v)
+ (or (number? v)
+ (boolean? v)
+ (string? 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))]
+ ['eq? eq?]
+ [_ false]))
+
+(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 (let-var (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) (let ((f (env-lookup x env)))
+ (if (let-var? f) (let-var-v f) f))]
+ [(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 (merge-let-vars env fun-env)))]))]))
+
+(define (merge-let-vars env1 env2)
+ (define (iter xs env)
+ (if (null? xs)
+ env
+ (let ((cur-var (car xs)))
+ (if (let-var? (mcdr cur-var))
+ (iter (cdr xs) (env-add (mcar cur-var) (mcdr cur-var) env))
+ (iter (cdr xs) env)))))
+ (iter (reverse (environ-xs env2)) env1))
+
+(define (eval e) (eval-env e env-empty))
+
+; ---------------------------------------------------------------- !!!
+
+(struct skip () #:transparent)
+(struct assign (x e) #:transparent)
+(struct if-cmd (eb ct cf) #:transparent)
+(struct while (eb cb) #:transparent)
+(struct comp (c1 c2) #:transparent)
+
+(define (cmd? c)
+ (match c
+ [(skip) true]
+ [(assign x e) (and (symbol? x) (expr? e))]
+ [(if-cmd eb ct cf) (and (expr? eb) (cmd? ct) (cmd? cf))]
+ [(while eb ct) (and (expr? eb) (cmd? ct))]
+ [else false]))
+
+(define (parse-while q)
+ (cond
+ [(eq? q 'skip) (skip)]
+ [(null? q) (skip)]
+ [(and (list? q) (= (length q) 3) (eq? (second q) ':=))
+ (assign (first q)
+ (parse (third q)))]
+ [(and (list? q) (= (length q) 4) (eq? (car q) 'if))
+ (if-cmd (parse (second q))
+ (parse-while (third q))
+ (parse-while (fourth q)))]
+ [(and (list? q) (= (length q) 3) (eq? (car q) 'while))
+ (while (parse (second q))
+ (parse-while (third q)))]
+ [(and (list? q) (= (length q) 2))
+ (comp (parse-while (first q))
+ (parse-while (second q)))]
+ [(and (list? q) (> (length q) 2))
+ (comp (parse-while (first q))
+ (parse-while (cdr q)))]
+ [else (error "while parse error")]))
+
+(define (eval-while e env)
+ (match e
+ [(skip) env]
+ [(assign x e)
+ (env-update x (eval-env e env) env)]
+ [(if-cmd eb ct cf)
+ (if (eval-env eb env)
+ (eval-while ct env)
+ (eval-while cf env))]
+ [(while eb cb)
+ (if (eval-env eb env)
+ (eval-while e (eval-while cb env))
+ env)]
+ [(comp c1 c2) (eval-while c2 (eval-while c1 env))]))
+
+; zakladamy, ze program startuje z pamiecia w ktorej
+; aktwna jest zmienna t
+(define WHILE_FACT
+ '{(i := 1)
+ (while (> t 0)
+ {(i := (* i t))
+ (t := (- t 1))})})
+
+(define (fact n)
+ (let* ([init-env (env-add 't n env-empty)]
+ [final-env
+ (eval-while (parse-while WHILE_FACT) init-env)])
+ (env-lookup 'i final-env)))
+
+(define prog1 '{(x := 5)
+ (f := (let [x 50] (lambda (y) (+ x y))))
+ (x := 10)
+ (z := (f 0))})
\ No newline at end of file diff --git a/semestr-2/racket/leftist.rkt b/semestr-2/racket/leftist.rkt new file mode 100644 index 0000000..78319e4 --- /dev/null +++ b/semestr-2/racket/leftist.rkt @@ -0,0 +1,105 @@ +#lang racket + +(provide make-elem elem-priority elem-val empty-heap heap-insert heap-merge heap-min heap-pop heap-empty?) + +(define (inc n) + (+ n 1)) + +;;; tagged lists +(define (tagged-list? len-xs tag xs) + (and (list? xs) + (= len-xs (length xs)) + (eq? (first xs) tag))) + +;;; ordered elements +(define (make-elem pri val) + (cons pri val)) + +(define (elem-priority x) + (car x)) + +(define (elem-val x) + (cdr x)) + +;;; leftist heaps (after Okasaki) + +;; data representation +(define leaf 'leaf) + +(define (leaf? h) (eq? 'leaf h)) + +(define (hnode? h) + (and (tagged-list? 5 'hnode h) + (natural? (caddr h)))) + +(define (make-hnode elem heap-a heap-b) + (if (< (rank heap-a) (rank heap-b)) + (list 'hnode elem (+ (rank heap-a) 1) heap-b heap-a) + (list 'hnode elem (+ (rank heap-b) 1) heap-a heap-b))) + +(define (hnode-elem h) + (second h)) + +(define (hnode-left h) + (fourth h)) + +(define (hnode-right h) + (fifth h)) + +(define (hnode-rank h) + (third h)) + +(define (hord? p h) + (or (leaf? h) + (<= p (elem-priority (hnode-elem h))))) + +(define (heap? h) + (or (leaf? h) + (and (hnode? h) + (heap? (hnode-left h)) + (heap? (hnode-right h)) + (<= (rank (hnode-right h)) + (rank (hnode-left h))) + (= (rank h) (inc (rank (hnode-right h)))) + (hord? (elem-priority (hnode-elem h)) + (hnode-left h)) + (hord? (elem-priority (hnode-elem h)) + (hnode-right h))))) + +(define (rank h) + (if (leaf? h) + 0 + (hnode-rank h))) + +;; operations + +(define empty-heap leaf) + +(define (heap-empty? h) + (leaf? h)) + +(define (heap-insert elt heap) + (heap-merge heap (make-hnode elt leaf leaf))) + +(define (heap-min heap) + (hnode-elem heap)) + +(define (heap-pop heap) + (heap-merge (hnode-left heap) (hnode-right heap))) + +(define (heap-merge h1 h2) + (cond + [(leaf? h1) h2] + [(leaf? h2) h1] + [else (let ((h1-min (heap-min h1)) + (h2-min (heap-min h2))) + (if (< (elem-priority h1-min) (elem-priority h2-min)) + (make-hnode h1-min (heap-merge (hnode-left h1) (hnode-right h1)) h2) + (make-hnode h2-min h1 (heap-merge (hnode-left h2) (hnode-right h2)))))])) + +;;; check that a list is sorted (useful for longish lists) +(define (sorted? xs) + (cond [(null? xs) true] + [(null? (cdr xs)) true] + [(<= (car xs) (cadr xs)) (sorted? (cdr xs))] + [else false])) diff --git a/semestr-2/racket/lista5/compiled/drracket/errortrace/prop_rkt.dep b/semestr-2/racket/lista5/compiled/drracket/errortrace/prop_rkt.dep new file mode 100644 index 0000000..6e0cfbb --- /dev/null +++ b/semestr-2/racket/lista5/compiled/drracket/errortrace/prop_rkt.dep @@ -0,0 +1 @@ +("7.6" racket ("f0a57e86828cdab35eaad454d5deb80353172518" . "8314027ed4c1c6fd9c412af77103e94790e59dd2") (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt")) diff --git a/semestr-2/racket/lista5/compiled/drracket/errortrace/prop_rkt.zo b/semestr-2/racket/lista5/compiled/drracket/errortrace/prop_rkt.zo Binary files differnew file mode 100644 index 0000000..748fec9 --- /dev/null +++ b/semestr-2/racket/lista5/compiled/drracket/errortrace/prop_rkt.zo diff --git a/semestr-2/racket/lista5/compiled/drracket/errortrace/props_rkt.dep b/semestr-2/racket/lista5/compiled/drracket/errortrace/props_rkt.dep new file mode 100644 index 0000000..0926afc --- /dev/null +++ b/semestr-2/racket/lista5/compiled/drracket/errortrace/props_rkt.dep @@ -0,0 +1 @@ +("7.6" racket ("e0347fa7e89f59bc97c197db02b440f666222428" . "8314027ed4c1c6fd9c412af77103e94790e59dd2") (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt")) diff --git a/semestr-2/racket/lista5/compiled/drracket/errortrace/props_rkt.zo b/semestr-2/racket/lista5/compiled/drracket/errortrace/props_rkt.zo Binary files differnew file mode 100644 index 0000000..eccc7f7 --- /dev/null +++ b/semestr-2/racket/lista5/compiled/drracket/errortrace/props_rkt.zo diff --git a/semestr-2/racket/lista5/compiled/drracket/errortrace/solution_rkt.dep b/semestr-2/racket/lista5/compiled/drracket/errortrace/solution_rkt.dep new file mode 100644 index 0000000..9810b4c --- /dev/null +++ b/semestr-2/racket/lista5/compiled/drracket/errortrace/solution_rkt.dep @@ -0,0 +1 @@ +("7.6" racket ("ae3a6974cdd4582f480927d9968aad2f495b7fc4" . "33b0c09c14dce6a2115d810ac3d0f25a9dce3205") #"C:\\Users\\franc\\Documents\\lista5\\props.rkt" (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt")) diff --git a/semestr-2/racket/lista5/compiled/drracket/errortrace/solution_rkt.zo b/semestr-2/racket/lista5/compiled/drracket/errortrace/solution_rkt.zo Binary files differnew file mode 100644 index 0000000..ca1ab20 --- /dev/null +++ b/semestr-2/racket/lista5/compiled/drracket/errortrace/solution_rkt.zo diff --git a/semestr-2/racket/lista5/julita/compiled/drracket/errortrace/props_rkt.dep b/semestr-2/racket/lista5/julita/compiled/drracket/errortrace/props_rkt.dep new file mode 100644 index 0000000..0926afc --- /dev/null +++ b/semestr-2/racket/lista5/julita/compiled/drracket/errortrace/props_rkt.dep @@ -0,0 +1 @@ +("7.6" racket ("e0347fa7e89f59bc97c197db02b440f666222428" . "8314027ed4c1c6fd9c412af77103e94790e59dd2") (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt")) diff --git a/semestr-2/racket/lista5/julita/compiled/drracket/errortrace/props_rkt.zo b/semestr-2/racket/lista5/julita/compiled/drracket/errortrace/props_rkt.zo Binary files differnew file mode 100644 index 0000000..eccc7f7 --- /dev/null +++ b/semestr-2/racket/lista5/julita/compiled/drracket/errortrace/props_rkt.zo diff --git a/semestr-2/racket/lista5/julita/props.rkt b/semestr-2/racket/lista5/julita/props.rkt new file mode 100644 index 0000000..204b108 --- /dev/null +++ b/semestr-2/racket/lista5/julita/props.rkt @@ -0,0 +1,52 @@ +#lang racket + +(provide conj conj-left conj-right conj? + disj disj-left disj-right disj? + neg neg-subf neg? + var?) + + +(define (conj p q) + (list 'conj p q)) + +(define (conj-left f) + (second f)) + +(define (conj-right f) + (third f)) + +(define (conj? t) + (and (list? t) + (= 3 (length t)) + (eq? 'conj (car t)))) + + +(define (disj p q) + (list 'disj p q)) + +(define (disj-left f) + (second f)) + +(define (disj-right f) + (third f)) + +(define (disj? t) + (and (list? t) + (= 3 (length t)) + (eq? 'disj (car t)))) + + +(define (neg x) + (list 'neg x)) + +(define (neg-subf x) + (second x)) + +(define (neg? t) + (and (list? t) + (= 2 (length t)) + (eq? 'neg (car t)))) + + +(define (var? t) + (symbol? t)) diff --git a/semestr-2/racket/lista5/julita/solution.bak b/semestr-2/racket/lista5/julita/solution.bak new file mode 100644 index 0000000..b3dda94 --- /dev/null +++ b/semestr-2/racket/lista5/julita/solution.bak @@ -0,0 +1,164 @@ +#lang racket + +;;Praca grupowa: +;;Dawid Holewa +;;Julita Osman +;;Aleksandra Stępniewska + +(require "props.rkt") +(provide falsifiable-cnf?) + +;Ponieważ formuła w cnf to konjunkcja klauzul +;a klauzula to alternatywa literałów +;to formuła w tej postaci jest tautologią +;wtedy i tylko wtedy gdy +;wszystkie klauzule w niej występujace sa zawsze prawdziwe (też są tautologiami) +;w przeciwnym razie, formulę taką da się zanegować; +;zatem nasz pomysł polega na tym, aby +;1)sprawdzic czy formula jest tautologia +;2)jesli tak to zwracamy fałsz +;3)wpp. pierwsza z klauzul, która nie jest tautologia +;(zatem jest mozliwa do zanegowania i jednocześnie neguje cała formułe w cnf) +;"przesuwamy" na początek listy reprezentującej cnf + +;dodatkowo to czy klauzula jest tautologią nie musimy sprawdzać wykonując wartościowanie +;możemy skorzystać z własności alternatywy +;klauzula bedzię zawsze pawdziwa tylko jeśli conajmniej jedna ze zmiennych występuje jednoczesnie ze swoją negacją + +;Falsifiable, która sprawdza każde wartościowania +;sprawdza 2^(ilosc zmiennych w całym wyrażeniu) wartosciowań, +;podczas gdy +;falsifiable, która opiera się na strukturze cnf +;przechodzi po cnf, aż do napotkania pierwszej +;mozliwej do zanegowania klauzuli +;zatem w najroszym przypadku przejdziemy po całym cnf +;ale zawsze wartosciowania negujacego formule szukamy tylko dla jedenej klauzuli +;zauważmy,ze jeśli formuła jest tautologią to oszczędzamy bardzo dużo czasu nie rozpartując wszystkich wartosciowań, tylko wypisujac odrazu falsz + +;Ta druga jest więc efektywniejsza + +(define (lit? f);; a lub ~a + (or (var? f) ;;a + (and (neg? f);;~a + (var? (neg-subf f))))) + +(define (lit-pos v) + v) + +(define (lit-neg v) + (neg v)) + +(define (lit-var l) ;;a-->a ~a-->a + (if (var? l) + l + (neg-subf l))) + +(define (lit-pos? l) + (var? l)) + +(define (to-nnf f) + (cond + [(var? f) (lit-pos f)] + [(neg? f) (to-nnf-neg (neg-subf f))] + [(conj? f) (conj (to-nnf (conj-left f)) + (to-nnf (conj-right f)))] + [(disj? f) (disj (to-nnf (disj-left f)) + (to-nnf (disj-right f)))])) + +(define (to-nnf-neg f) + (cond + [(var? f) (lit-neg f)] + [(neg? f) (to-nnf (neg-subf f))] + [(conj? f) (disj (to-nnf-neg (conj-left f)) + (to-nnf-neg (conj-right f)))] + [(disj? f) (conj (to-nnf-neg (disj-left f)) + (to-nnf-neg (disj-right f)))])) + +(define (mk-cnf xss) + (cons 'cnf xss)) + +(define (clause? f) + (and (list? f) + (andmap lit? f))) + +(define (cnf? f) + (and (pair? f) + (eq? 'cnf (car f)) + (list? (cdr f)) + (andmap clause? (cdr f)))) + +(define (to-cnf f) + (define (join xss yss) + (apply append (map (lambda (xs) (map (lambda (ys) (append xs ys)) yss)) xss))) + + (define (go f) + (cond + [(lit? f) (list (list f))] + [(conj? f) (append (go (conj-left f)) + (go (conj-right f)))] + [(disj? f) (join (go (disj-left f)) + (go (disj-right f)))])) + (mk-cnf (go f))) + + +(define (contain-both-literals? claus) + (define (aux to-check) + (cond [(empty? to-check) #f] + [(neg? (car to-check)) + (if (memq (neg-subf (car to-check)) claus) + #t + (aux (cdr to-check)))] + [else (aux (cdr to-check))])) + (aux claus)) + + +;; sprawdza czy ktorakolwiek z klauzul z listy reprezentujacej cnf +;; zawiera chociaz jedną parę zmiennej i jej negacji +;; zwraca liste pusta jesli cnf jest tautologia +;; zwraca liste z pierwsza klauzule nie bedaca tautologia "przesunieta" na poczatek (possible-to-neg) +(define (has-both big-set) + (define (possible-to-neg big-set x) ;;przesuwa x-ty element listy big-set na poczatek + (define x-ty (list-ref big-set x)) + (append (list x-ty) (remove x-ty big-set))) + (define (aux iter big-set) + (if (= iter (length big-set)) + '() + (if (contain-both-literals? (list-ref big-set iter)) ;;sprawdzamy czy iter klauzula cnf ma wystapienie a i ~a jednoczesnie + (aux (+ iter 1) big-set) + (possible-to-neg big-set iter)))) + (aux 0 (cdr big-set))) ;;(cdr big-set) bo to cnf czyli pierwszy element listy to edykieta 'cnf + + +(define (falsifiable-cnf? t) + (define tt (to-cnf (to-nnf t))) + (define f (has-both tt)) + (if (empty? f) + #f + (find-valuation f))) + + +(define (valuate f sigma) + (define (insigma-proc lista result) + (cond [(null? lista) result] + [(insigma-proc (cdr lista) (append result (list (lit-var(caar lista)))))])) + ;; insigma ---> lista zmiennych z wartosciowania pierwszej klauzuli: + (define insigma (insigma-proc sigma '())) + (define (aux insigma otherclause sigma) + (cond [(null? otherclause) sigma] + [(if (memq (lit-var (car otherclause)) insigma) + (aux insigma (cdr otherclause) sigma) + (if(neg? (car otherclause)) + (aux (append insigma (list(car otherclause))) + (cdr otherclause) + (append sigma (list(list (lit-var(car otherclause)) 1)))) + (aux (append insigma (list(car otherclause))) + (cdr otherclause) + (append sigma (list(list (car otherclause) 0))))))])) + (if (empty? f) + sigma + (valuate (cdr f) + (aux insigma (car f) sigma)))) + +(define (find-valuation f) + (valuate f '())) + diff --git a/semestr-2/racket/lista5/julita/solution.rkt b/semestr-2/racket/lista5/julita/solution.rkt new file mode 100644 index 0000000..da87bf9 --- /dev/null +++ b/semestr-2/racket/lista5/julita/solution.rkt @@ -0,0 +1,164 @@ +#lang racket + +;;Praca grupowa: +;;Dawid Holewa +;;Julita Osman +;;Aleksandra Stępniewska + +(require "props.rkt") +(provide falsifiable-cnf?) + +;Ponieważ formuła w cnf to konjunkcja klauzul +;a klauzula to alternatywa literałów +;to formuła w tej postaci jest tautologią +;wtedy i tylko wtedy gdy +;wszystkie klauzule w niej występujace sa zawsze prawdziwe (też są tautologiami) +;w przeciwnym razie, formulę taką da się zanegować; +;zatem nasz pomysł polega na tym, aby +;1)sprawdzic czy formula jest tautologia +;2)jesli tak to zwracamy fałsz +;3)wpp. pierwsza z klauzul, która nie jest tautologia +;(zatem jest mozliwa do zanegowania i jednocześnie neguje cała formułe w cnf) +;"przesuwamy" na początek listy reprezentującej cnf + +;dodatkowo to czy klauzula jest tautologią nie musimy sprawdzać wykonując wartościowanie +;możemy skorzystać z własności alternatywy +;klauzula bedzię zawsze pawdziwa tylko jeśli conajmniej jedna ze zmiennych występuje jednoczesnie ze swoją negacją + +;Falsifiable, która sprawdza każde wartościowania +;sprawdza 2^(ilosc zmiennych w całym wyrażeniu) wartosciowań, +;podczas gdy +;falsifiable, która opiera się na strukturze cnf +;przechodzi po cnf, aż do napotkania pierwszej +;mozliwej do zanegowania klauzuli +;zatem w najroszym przypadku przejdziemy po całym cnf +;ale zawsze wartosciowania negujacego formule szukamy tylko dla jedenej klauzuli +;zauważmy,ze jeśli formuła jest tautologią to oszczędzamy bardzo dużo czasu nie rozpartując wszystkich wartosciowań, tylko wypisujac odrazu falsz + +;Ta druga jest więc efektywniejsza + +(define (lit? f);; a lub ~a + (or (var? f) ;;a + (and (neg? f);;~a + (var? (neg-subf f))))) + +(define (lit-pos v) + v) + +(define (lit-neg v) + (neg v)) + +(define (lit-var l) ;;a-->a ~a-->a + (if (var? l) + l + (neg-subf l))) + +(define (lit-pos? l) + (var? l)) + +(define (to-nnf f) + (cond + [(var? f) (lit-pos f)] + [(neg? f) (to-nnf-neg (neg-subf f))] + [(conj? f) (conj (to-nnf (conj-left f)) + (to-nnf (conj-right f)))] + [(disj? f) (disj (to-nnf (disj-left f)) + (to-nnf (disj-right f)))])) + +(define (to-nnf-neg f) + (cond + [(var? f) (lit-neg f)] + [(neg? f) (to-nnf (neg-subf f))] + [(conj? f) (disj (to-nnf-neg (conj-left f)) + (to-nnf-neg (conj-right f)))] + [(disj? f) (conj (to-nnf-neg (disj-left f)) + (to-nnf-neg (disj-right f)))])) + +(define (mk-cnf xss) + (cons 'cnf xss)) + +(define (clause? f) + (and (list? f) + (andmap lit? f))) + +(define (cnf? f) + (and (pair? f) + (eq? 'cnf (car f)) + (list? (cdr f)) + (andmap clause? (cdr f)))) + +(define (to-cnf f) + (define (join xss yss) + (apply append (map (lambda (xs) (map (lambda (ys) (append xs ys)) yss)) xss))) + + (define (go f) + (cond + [(lit? f) (list (list f))] + [(conj? f) (append (go (conj-left f)) + (go (conj-right f)))] + [(disj? f) (join (go (disj-left f)) + (go (disj-right f)))])) + (mk-cnf (go f))) + + +(define (contain-both-literals? claus) + (define (aux to-check) + (cond [(empty? to-check) #f] + [(neg? (car to-check)) + (if (memq (neg-subf (car to-check)) claus) + #t + (aux (cdr to-check)))] + [else (aux (cdr to-check))])) + (aux claus)) + + +;; sprawdza czy ktorakolwiek z klauzul z listy reprezentujacej cnf +;; zawiera chociaz jedną parę zmiennej i jej negacji +;; zwraca liste pusta jesli cnf jest tautologia +;; zwraca liste z pierwsza klauzule nie bedaca tautologia "przesunieta" na poczatek (possible-to-neg) +(define (has-both big-set) + (define (possible-to-neg big-set x) ;;przesuwa x-ty element listy big-set na poczatek + (define x-ty (list-ref big-set x)) + (append (list x-ty) (remove x-ty big-set))) + (define (aux iter big-set) + (if (= iter (length big-set)) + '() + (if (contain-both-literals? (list-ref big-set iter)) ;;sprawdzamy czy iter klauzula cnf ma wystapienie a i ~a jednoczesnie + (aux (+ iter 1) big-set) + (possible-to-neg big-set iter)))) + (aux 0 (cdr big-set))) ;;(cdr big-set) bo to cnf czyli pierwszy element listy to edykieta 'cnf + + +(define (falsifiable-cnf? t) + (define tt (to-cnf (to-nnf t))) + (define f (has-both tt)) + (if (empty? f) + #f + (find-valuation f))) + + +(define (valuate f sigma) + (define (insigma-proc lista result) + (cond [(null? lista) result] + [(insigma-proc (cdr lista) (append result (list (lit-var(caar lista)))))])) + ;; insigma ---> lista zmiennych z wartosciowania pierwszej klauzuli: + (define insigma (insigma-proc sigma '())) + (define (aux insigma otherclause sigma) + (cond [(null? otherclause) sigma] + [(if (memq (lit-var (car otherclause)) insigma) + (aux insigma (cdr otherclause) sigma) + (if(neg? (car otherclause)) + (aux (append insigma (list(car otherclause))) + (cdr otherclause) + (append sigma (list(list (lit-var(car otherclause)) true)))) + (aux (append insigma (list(car otherclause))) + (cdr otherclause) + (append sigma (list(list (car otherclause) false))))))])) + (if (empty? f) + sigma + (valuate (cdr f) + (aux insigma (car f) sigma)))) + +(define (find-valuation f) + (valuate f '())) + diff --git a/semestr-2/racket/lista5/prop.rkt b/semestr-2/racket/lista5/prop.rkt new file mode 100644 index 0000000..6f1f7b4 --- /dev/null +++ b/semestr-2/racket/lista5/prop.rkt @@ -0,0 +1 @@ +#lang racket diff --git a/semestr-2/racket/lista5/props.bak b/semestr-2/racket/lista5/props.bak new file mode 100644 index 0000000..1a5659a --- /dev/null +++ b/semestr-2/racket/lista5/props.bak @@ -0,0 +1,71 @@ +#lang racket + +(provide var? + neg? + conj? + disj? + conj + disj + neg + conj-left + conj-right + disj-right + disj-left + neg-subf) +; (require "solution.rkt") + +(define (var? t) (symbol? t)) + +(define (neg? t) + (and (list? t) + (= 2 (length t)) + (eq? 'neg (car t)))) + +(define (conj? t) + (and (list? t) + (= 3 (length t)) + (eq? 'conj (car t)))) + +(define (disj? t) + (and (list? t) + (= 3 (length t)) + (eq? 'disj (car t)))) + +(define (lit? t) + (or (var? t) + (and (neg? t) + (var? (neg-subf t))))) + +(define (conj left right) + (list 'conj left right)) + +(define (disj left right) + (list 'disj left right)) + +(define (neg f) + (list 'neg f)) + +(define (conj-left f) + (if (conj? f) + (cadr f) + (error "Złe dane ze znacznikiem -- CONJ-LEFT" f))) + +(define (conj-right f) + (if (conj? f) + (caddr f) + (error "Złe dane ze znacznikiem -- CONJ-RIGHT" f))) + +(define (disj-left f) + (if (disj? f) + (cadr f) + (error "Złe dane ze znacznikiem -- DISJ-LEFT" f))) + +(define (disj-right f) + (if (disj? f) + (caddr f) + (error "Złe dane ze znacznikiem -- DISJ-RIGHT" f))) + +(define (neg-subf f) + (if (neg? f) + (cadr f) + (error "Złe dane ze znacznikiem -- NEG-FORM" f))) diff --git a/semestr-2/racket/lista5/props.rkt b/semestr-2/racket/lista5/props.rkt new file mode 100644 index 0000000..204b108 --- /dev/null +++ b/semestr-2/racket/lista5/props.rkt @@ -0,0 +1,52 @@ +#lang racket + +(provide conj conj-left conj-right conj? + disj disj-left disj-right disj? + neg neg-subf neg? + var?) + + +(define (conj p q) + (list 'conj p q)) + +(define (conj-left f) + (second f)) + +(define (conj-right f) + (third f)) + +(define (conj? t) + (and (list? t) + (= 3 (length t)) + (eq? 'conj (car t)))) + + +(define (disj p q) + (list 'disj p q)) + +(define (disj-left f) + (second f)) + +(define (disj-right f) + (third f)) + +(define (disj? t) + (and (list? t) + (= 3 (length t)) + (eq? 'disj (car t)))) + + +(define (neg x) + (list 'neg x)) + +(define (neg-subf x) + (second x)) + +(define (neg? t) + (and (list? t) + (= 2 (length t)) + (eq? 'neg (car t)))) + + +(define (var? t) + (symbol? t)) diff --git a/semestr-2/racket/lista5/skrr/solution.bak b/semestr-2/racket/lista5/skrr/solution.bak new file mode 100644 index 0000000..72c7f36 --- /dev/null +++ b/semestr-2/racket/lista5/skrr/solution.bak @@ -0,0 +1,135 @@ +#lang racket + +(provide falsifiable-cnf?) +(require "props.rkt") + +(define (prop? f) + (or (var? f) + (and (neg? f) + (prop? (neg-subf f))) + (and (disj? f) + (prop? (disj-left f)) + (prop? (disj-right f))) + (and (conj? f) + (prop? (conj-left f)) + (prop? (conj-right f))))) + +(define (lit-var f) + (cond [(var? f) f] + [(neg? f) (neg-subf f)] + [else (error "Złe dane ze znacznikiem -- LIT-VAR" f)])) + +(define (free-vars f) + (cond [(null? f) null] + [(var? f) (list f)] + [(neg? f) (free-vars (neg-subf f))] + [(conj? f) (append (free-vars (conj-left f)) + (free-vars (conj-right f)))] + [(disj? f) (append (free-vars (disj-left f)) + (free-vars (disj-right f)))] + [else (error "Zła formula -- FREE-VARS" f)])) + +(define (gen-vals xs) + (if (null? xs) + (list null) + (let* + ((vss (gen-vals (cdr xs))) + (x (car xs)) + (vst (map (λ (vs) (cons (list x true) vs)) vss)) + (vsf (map (λ (vs) (cons (list x false) vs)) vss))) + (append vst vsf)))) + +(define (eval-formula f evaluation) + (cond [(var? f) + (let ((val (assoc f evaluation))) + (if (not val) + (error "Zmienna wolna nie wystepuje w wartościowaniu -- EVAL-FORMULA" f evaluation) + (cadr val)))] + [(neg? f) (not (eval-formula (neg-subf f) evaluation))] + [(disj? f) (or (eval-formula (disj-left f) evaluation) + (eval-formula (disj-right f) evaluation))] + [(conj? f) (and (eval-formula (conj-left f) evaluation) + (eval-formula (conj-right f) evaluation))] + [else (error "Zła formuła -- EVAL-FORMULA" f evaluation)])) + +(define (falsifiable-eval? f) + (let* ((evaluations (gen-vals (free-vars f))) + (results (map (λ (evaluation) (eval-formula f evaluation)) evaluations))) + (ormap false? results))) + +(define (nff? f) + (cond [(lit? f) true] + [(neg? f) false] + [(conj? f) (and (nff? (conj-left f)) + (nff? (conj-right f)))] + [(disj? f) (and (nff? (disj-left f)) + (nff? (disj-right f)))] + [else (error "Zła formuła -- NFF?" f)])) + +(define (convert-to-nnf f) + (cond [(lit? f) f] + [(neg? f) (convert-negation (neg-subf f))] + [(conj? f) (conj (convert-to-nnf (conj-left f)) + (convert-to-nnf (conj-right f)))] + [(disj? f) (disj (convert-to-nnf (disj-left f)) + (convert-to-nnf (disj-right f)))] + [else (error "Zła formuła -- CONVERT" f)])) + +(define (convert-negation f) + (cond [(lit? f) + (if (var? f) + (neg f) + (neg-subf f))] + [(neg? f) (convert-to-nnf (neg-subf f))] + [(conj? f) (disj (convert-negation (conj-left f)) + (convert-negation (conj-right f)))] + [(disj? f) (conj (convert-negation (disj-left f)) + (convert-negation (disj-right f)))] + [else (error "Zła formuła -- CONVERT-NEGATION" f)])) + +(define (clause? x) + (and (list? x) + (andmap lit? x))) + +(define (clause-empty? x) + (and (clause? x) + (null? x))) + +(define (cnf? x) + (and (list? x) + (andmap clause? x))) + +(define (flatmap proc seq) + (foldl append null (map proc seq))) + +(define (convert-to-cnf f) + (define (convert f) + (cond [(lit? f) (list (list f))] + [(conj? f) (append (convert-to-cnf (conj-left f)) + (convert-to-cnf (conj-right f)))] + [(disj? f) + (let ((clause-left (convert-to-cnf (disj-left f))) + (clause-right (convert-to-cnf (disj-right f)))) + (flatmap (λ (clause) + (map (λ (clause2) + (append clause2 clause)) clause-left)) + clause-right))])) + (convert (convert-to-nnf f))) + +(define (falsifiable-clause? clause) + (cond [(clause-empty? clause) true] + [(lit? (findf (λ (l) (equal? + l + (convert-to-nnf (neg (car clause))))) + clause)) false] + [else (falsifiable-clause? (cdr clause))])) + +(define (falsifiable-cnf? f) + (define (neg-value lit) + (if (var? lit) + (list lit false) + (list (neg-subf lit) true))) + (ormap (λ (clause) (if (falsifiable-clause? clause) + (map neg-value clause) + false)) + (convert-to-cnf f)))
\ No newline at end of file diff --git a/semestr-2/racket/lista5/skrr/solution.rkt b/semestr-2/racket/lista5/skrr/solution.rkt new file mode 100644 index 0000000..e8efbc9 --- /dev/null +++ b/semestr-2/racket/lista5/skrr/solution.rkt @@ -0,0 +1,88 @@ +#lang racket + +(require "props.rkt") +(provide falsifiable-cnf?) + +(define (lit? f) + (or (var? f) + (and (neg? f) + (var? (neg-subf f))))) + +(define (lit-pos v) + v) + +(define (lit-neg v) + (neg v)) + +(define (lit-var l) + (if (var? l) + l + (neg-subf l))) + +(define (lit-pos? l) + (var? l)) + +(define (to-nnf f) + (cond + [(var? f) (lit-pos f)] + [(neg? f) (to-nnf-neg (neg-subf f))] + [(conj? f) (conj (to-nnf (conj-left f)) + (to-nnf (conj-right f)))] + [(disj? f) (disj (to-nnf (disj-left f)) + (to-nnf (disj-right f)))])) + +(define (to-nnf-neg f) + (cond + [(var? f) (lit-neg f)] + [(neg? f) (to-nnf (neg-subf f))] + [(conj? f) (disj (to-nnf-neg (conj-left f)) + (to-nnf-neg (conj-right f)))] + [(disj? f) (conj (to-nnf-neg (disj-left f)) + (to-nnf-neg (disj-right f)))])) + +(define (mk-cnf xss) + (cons 'cnf xss)) + +(define (clause? f) + (and (list? f) + (andmap lit? f))) + +(define (cnf? f) + (and (pair? f) + (eq? 'cnf (car f)) + (list? (cdr f)) + (andmap clause? (cdr f)))) + +(define (to-cnf f) + (define (join xss yss) + (apply append (map (lambda (xs) (map (lambda (ys) (append xs ys)) yss)) xss))) + (define (go f) + (cond + [(lit? f) (list (list f))] + [(conj? f) (append (go (conj-left f)) + (go (conj-right f)))] + [(disj? f) (join (go (disj-left f)) + (go (disj-right f)))])) + (mk-cnf (go f))) + +(define (clause-empty? x) + (and (clause? x) + (null? x))) + +(define (falsifiable-clause? clause) + (cond [(clause-empty? clause) true] + [(lit? (findf (λ (l) (equal? + l + (to-nnf (neg (car clause))))) + clause)) false] + [else (falsifiable-clause? (cdr clause))])) + +(define (falsifiable-cnf? f) + (define (neg-value lit) + (if (var? lit) + (list lit false) + (list (neg-subf lit) true))) + (ormap (λ (clause) (if (falsifiable-clause? clause) + (map neg-value clause) + false)) + (convert-to-cnf f)))
\ No newline at end of file diff --git a/semestr-2/racket/lista5/sol2.rkt b/semestr-2/racket/lista5/sol2.rkt new file mode 100644 index 0000000..d037472 --- /dev/null +++ b/semestr-2/racket/lista5/sol2.rkt @@ -0,0 +1,90 @@ +#lang racket +(provide falsifiable-cnf?) (require "props.rkt") + + +(define (falsifiable-cnf? p) + ;literał + (define (lit? p) + (or (var? p) + (and (neg? p) (var? (neg-subf p))) + )) + + (define (lit-pos? p) + (if (lit? p) + (var? p) + (error "not a literal" p) + )) + + (define (lit-var p) + (cond + [(not (lit? p)) (error "not a literal" p)] + [(lit-pos? p) p] + [else (neg-subf p)] + )) + + (define (contr p) + (if (lit? p) + (if (neg? p) (neg-subf p) (neg p)) + (error "not a literal" p) + )) + + ;konwertowanie + (define (convert-to-cnf p) + (define (convert-to-nnf p) + (cond + [(lit? p) p] + [(and (neg? p) (conj? (neg-subf p))) + (let ((A (neg-subf p))) + (disj (convert-to-nnf (neg (conj-left A))) (convert-to-nnf (neg (conj-right A)))))] + [(and (neg? p) (disj? (neg-subf p))) + (let ((A (neg-subf p))) + (conj (convert-to-nnf (neg (disj-left A))) (convert-to-nnf (neg (disj-right A)))))] + [(and (neg? p) (neg? (neg-subf p))) (convert-to-nnf (neg-subf (neg-subf p)))] + [(conj? p) (conj (convert-to-nnf (conj-right p)) (convert-to-nnf (conj-left p)))] + [(disj? p) (disj (convert-to-nnf (disj-right p)) (convert-to-nnf (disj-left p)))] + [else (error "not a proposition" p)])) + + (define (flatmap proc seq) + (foldr append null (map proc seq))) + + (define (merge a b) + (flatmap (lambda (c) (map (lambda (c2) (append c c2)) b)) a)) + + (define (convert p) + (cond + [(lit? p) (list (list p))] + [(conj? p) (append (convert (conj-left p)) (convert (conj-right p)))] + [(disj? p) (let* ((L (convert (disj-left p))) (R (convert (disj-right p)))) + (merge L R))] + [else (error "it should never be here" p)] + )) + + (map (lambda (c) (remove-duplicates c)) (convert (convert-to-nnf p)))) + + ;prawdziwa funkcja + (define cnf (convert-to-cnf p)) + + (define (falsifiable-clause? c) + (cond + [(null? c) #t] + [(eq? #f (member (contr (car c)) c)) (falsifiable-clause? (cdr c))] + [else #f] + )) + + (define (falsified-clause c) + (if (null? c) + null + (cons (list (lit-var (car c)) (not (lit-pos? (car c)))) (falsified-clause (cdr c))) + )) + + (define (falsified-val p) + (cond + [(null? p) false] + [(falsifiable-clause? (car p)) (falsified-clause (car p))] + [else (falsified-val (cdr p))] + ) + ) + (falsified-val cnf)) + + +;złożoność wykładnicza tak jak falsible-eval ale często w praktyce szybsza jak nie ma za dużo alternatyw.
\ No newline at end of file diff --git a/semestr-2/racket/lista5/solution.bak b/semestr-2/racket/lista5/solution.bak new file mode 100644 index 0000000..72c7f36 --- /dev/null +++ b/semestr-2/racket/lista5/solution.bak @@ -0,0 +1,135 @@ +#lang racket + +(provide falsifiable-cnf?) +(require "props.rkt") + +(define (prop? f) + (or (var? f) + (and (neg? f) + (prop? (neg-subf f))) + (and (disj? f) + (prop? (disj-left f)) + (prop? (disj-right f))) + (and (conj? f) + (prop? (conj-left f)) + (prop? (conj-right f))))) + +(define (lit-var f) + (cond [(var? f) f] + [(neg? f) (neg-subf f)] + [else (error "Złe dane ze znacznikiem -- LIT-VAR" f)])) + +(define (free-vars f) + (cond [(null? f) null] + [(var? f) (list f)] + [(neg? f) (free-vars (neg-subf f))] + [(conj? f) (append (free-vars (conj-left f)) + (free-vars (conj-right f)))] + [(disj? f) (append (free-vars (disj-left f)) + (free-vars (disj-right f)))] + [else (error "Zła formula -- FREE-VARS" f)])) + +(define (gen-vals xs) + (if (null? xs) + (list null) + (let* + ((vss (gen-vals (cdr xs))) + (x (car xs)) + (vst (map (λ (vs) (cons (list x true) vs)) vss)) + (vsf (map (λ (vs) (cons (list x false) vs)) vss))) + (append vst vsf)))) + +(define (eval-formula f evaluation) + (cond [(var? f) + (let ((val (assoc f evaluation))) + (if (not val) + (error "Zmienna wolna nie wystepuje w wartościowaniu -- EVAL-FORMULA" f evaluation) + (cadr val)))] + [(neg? f) (not (eval-formula (neg-subf f) evaluation))] + [(disj? f) (or (eval-formula (disj-left f) evaluation) + (eval-formula (disj-right f) evaluation))] + [(conj? f) (and (eval-formula (conj-left f) evaluation) + (eval-formula (conj-right f) evaluation))] + [else (error "Zła formuła -- EVAL-FORMULA" f evaluation)])) + +(define (falsifiable-eval? f) + (let* ((evaluations (gen-vals (free-vars f))) + (results (map (λ (evaluation) (eval-formula f evaluation)) evaluations))) + (ormap false? results))) + +(define (nff? f) + (cond [(lit? f) true] + [(neg? f) false] + [(conj? f) (and (nff? (conj-left f)) + (nff? (conj-right f)))] + [(disj? f) (and (nff? (disj-left f)) + (nff? (disj-right f)))] + [else (error "Zła formuła -- NFF?" f)])) + +(define (convert-to-nnf f) + (cond [(lit? f) f] + [(neg? f) (convert-negation (neg-subf f))] + [(conj? f) (conj (convert-to-nnf (conj-left f)) + (convert-to-nnf (conj-right f)))] + [(disj? f) (disj (convert-to-nnf (disj-left f)) + (convert-to-nnf (disj-right f)))] + [else (error "Zła formuła -- CONVERT" f)])) + +(define (convert-negation f) + (cond [(lit? f) + (if (var? f) + (neg f) + (neg-subf f))] + [(neg? f) (convert-to-nnf (neg-subf f))] + [(conj? f) (disj (convert-negation (conj-left f)) + (convert-negation (conj-right f)))] + [(disj? f) (conj (convert-negation (disj-left f)) + (convert-negation (disj-right f)))] + [else (error "Zła formuła -- CONVERT-NEGATION" f)])) + +(define (clause? x) + (and (list? x) + (andmap lit? x))) + +(define (clause-empty? x) + (and (clause? x) + (null? x))) + +(define (cnf? x) + (and (list? x) + (andmap clause? x))) + +(define (flatmap proc seq) + (foldl append null (map proc seq))) + +(define (convert-to-cnf f) + (define (convert f) + (cond [(lit? f) (list (list f))] + [(conj? f) (append (convert-to-cnf (conj-left f)) + (convert-to-cnf (conj-right f)))] + [(disj? f) + (let ((clause-left (convert-to-cnf (disj-left f))) + (clause-right (convert-to-cnf (disj-right f)))) + (flatmap (λ (clause) + (map (λ (clause2) + (append clause2 clause)) clause-left)) + clause-right))])) + (convert (convert-to-nnf f))) + +(define (falsifiable-clause? clause) + (cond [(clause-empty? clause) true] + [(lit? (findf (λ (l) (equal? + l + (convert-to-nnf (neg (car clause))))) + clause)) false] + [else (falsifiable-clause? (cdr clause))])) + +(define (falsifiable-cnf? f) + (define (neg-value lit) + (if (var? lit) + (list lit false) + (list (neg-subf lit) true))) + (ormap (λ (clause) (if (falsifiable-clause? clause) + (map neg-value clause) + false)) + (convert-to-cnf f)))
\ No newline at end of file diff --git a/semestr-2/racket/lista5/solution.rkt b/semestr-2/racket/lista5/solution.rkt new file mode 100644 index 0000000..67964d8 --- /dev/null +++ b/semestr-2/racket/lista5/solution.rkt @@ -0,0 +1,140 @@ +#lang racket + +(provide falsifiable-cnf?) +(require "props.rkt") + +(define (prop? f) + (or (var? f) + (and (neg? f) + (prop? (neg-subf f))) + (and (disj? f) + (prop? (disj-left f)) + (prop? (disj-right f))) + (and (conj? f) + (prop? (conj-left f)) + (prop? (conj-right f))))) + +(define (lit? t) + (or (var? t) + (and (neg? t) + (var? (neg-subf t))))) + +(define (lit-var f) + (cond [(var? f) f] + [(neg? f) (neg-subf f)] + [else (error "Złe dane ze znacznikiem -- LIT-VAR" f)])) + +(define (free-vars f) + (cond [(null? f) null] + [(var? f) (list f)] + [(neg? f) (free-vars (neg-subf f))] + [(conj? f) (append (free-vars (conj-left f)) + (free-vars (conj-right f)))] + [(disj? f) (append (free-vars (disj-left f)) + (free-vars (disj-right f)))] + [else (error "Zła formula -- FREE-VARS" f)])) + +(define (gen-vals xs) + (if (null? xs) + (list null) + (let* + ((vss (gen-vals (cdr xs))) + (x (car xs)) + (vst (map (λ (vs) (cons (list x true) vs)) vss)) + (vsf (map (λ (vs) (cons (list x false) vs)) vss))) + (append vst vsf)))) + +(define (eval-formula f evaluation) + (cond [(var? f) + (let ((val (assoc f evaluation))) + (if (not val) + (error "Zmienna wolna nie wystepuje w wartościowaniu -- EVAL-FORMULA" f evaluation) + (cadr val)))] + [(neg? f) (not (eval-formula (neg-subf f) evaluation))] + [(disj? f) (or (eval-formula (disj-left f) evaluation) + (eval-formula (disj-right f) evaluation))] + [(conj? f) (and (eval-formula (conj-left f) evaluation) + (eval-formula (conj-right f) evaluation))] + [else (error "Zła formuła -- EVAL-FORMULA" f evaluation)])) + +(define (falsifiable-eval? f) + (let* ((evaluations (gen-vals (free-vars f))) + (results (map (λ (evaluation) (eval-formula f evaluation)) evaluations))) + (ormap false? results))) + +(define (nff? f) + (cond [(lit? f) true] + [(neg? f) false] + [(conj? f) (and (nff? (conj-left f)) + (nff? (conj-right f)))] + [(disj? f) (and (nff? (disj-left f)) + (nff? (disj-right f)))] + [else (error "Zła formuła -- NFF?" f)])) + +(define (convert-to-nnf f) + (cond [(lit? f) f] + [(neg? f) (convert-negation (neg-subf f))] + [(conj? f) (conj (convert-to-nnf (conj-left f)) + (convert-to-nnf (conj-right f)))] + [(disj? f) (disj (convert-to-nnf (disj-left f)) + (convert-to-nnf (disj-right f)))] + [else (error "Zła formuła -- CONVERT" f)])) + +(define (convert-negation f) + (cond [(lit? f) + (if (var? f) + (neg f) + (neg-subf f))] + [(neg? f) (convert-to-nnf (neg-subf f))] + [(conj? f) (disj (convert-negation (conj-left f)) + (convert-negation (conj-right f)))] + [(disj? f) (conj (convert-negation (disj-left f)) + (convert-negation (disj-right f)))] + [else (error "Zła formuła -- CONVERT-NEGATION" f)])) + +(define (clause? x) + (and (list? x) + (andmap lit? x))) + +(define (clause-empty? x) + (and (clause? x) + (null? x))) + +(define (cnf? x) + (and (list? x) + (andmap clause? x))) + +(define (flatmap proc seq) + (foldl append null (map proc seq))) + +(define (convert-to-cnf f) + (define (convert f) + (cond [(lit? f) (list (list f))] + [(conj? f) (append (convert-to-cnf (conj-left f)) + (convert-to-cnf (conj-right f)))] + [(disj? f) + (let ((clause-left (convert-to-cnf (disj-left f))) + (clause-right (convert-to-cnf (disj-right f)))) + (flatmap (λ (clause) + (map (λ (clause2) + (append clause2 clause)) clause-left)) + clause-right))])) + (map (lambda (clause) (remove-duplicates clause)) (convert (convert-to-nnf f)))) + +(define (falsifiable-clause? clause) + (cond [(clause-empty? clause) true] + [(lit? (findf (λ (l) (equal? + l + (convert-to-nnf (neg (car clause))))) + clause)) false] + [else (falsifiable-clause? (cdr clause))])) + +(define (falsifiable-cnf? f) + (define (neg-value lit) + (if (var? lit) + (list lit false) + (list (neg-subf lit) true))) + (ormap (λ (clause) (if (falsifiable-clause? clause) + (map neg-value clause) + false)) + (convert-to-cnf f)))
\ No newline at end of file diff --git a/semestr-2/racket/lista5/xd.bak b/semestr-2/racket/lista5/xd.bak new file mode 100644 index 0000000..d814e10 --- /dev/null +++ b/semestr-2/racket/lista5/xd.bak @@ -0,0 +1,4 @@ +#lang racket + +(require "solution.rkt") + diff --git a/semestr-2/racket/lista5/xd.rkt b/semestr-2/racket/lista5/xd.rkt new file mode 100644 index 0000000..64ce78c --- /dev/null +++ b/semestr-2/racket/lista5/xd.rkt @@ -0,0 +1,4 @@ +#lang racket + +(require "solution.rkt") +(require "props.rkt") diff --git a/semestr-2/racket/lista6/lista8/kappa.py b/semestr-2/racket/lista6/lista8/kappa.py new file mode 100644 index 0000000..f359d5c --- /dev/null +++ b/semestr-2/racket/lista6/lista8/kappa.py @@ -0,0 +1,13 @@ +import pylab
+
+a = int(input("podaj liczbe: "))
+b = int(input("podaj liczbe: "))
+
+x = range(-10, 11)
+y = []
+for i in x:
+ y.append(a * i + b)
+pylab.plot(x, y)
+pylab.title('Wykres f(x) = a*x - b')
+pylab.grid(True)
+pylab.show()
diff --git a/semestr-2/racket/lista6/lista8/zad1.bak b/semestr-2/racket/lista6/lista8/zad1.bak new file mode 100644 index 0000000..0960f21 --- /dev/null +++ b/semestr-2/racket/lista6/lista8/zad1.bak @@ -0,0 +1,98 @@ +#lang racket + +; Do let-env.rkt dodajemy wartosci boolowskie +; +; 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 if-expr (eb et ef) #: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))] + [(if-expr eb et ef) ; <--------------------------------------- !!! + (and (expr? eb) (expr? et) (expr? ef))] + [_ false])) + +(define (parse q) + (cond + [(number? q) (const q)] + [(eq? q 'true) (const true)] ; <---------------------------- !!! + [(eq? q 'false) (const false)] ; <---------------------------- !!! + [(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) 4) (eq? (first q) 'if)) ; <--- !!! + (if-expr (parse (second q)) + (parse (third q)) + (parse (fourth q)))] + [(and (list? q) (eq? (length q) 3) (symbol? (first q))) + (binop (first q) + (parse (second q)) + (parse (third q)))])) + +(define (test-parse) (parse '(let [x (+ 2 2)] (+ x 1)))) + +; ---------- ; +; Srodowiska ; +; ---------- ; + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; Ewaluacja ; +; --------- ; + +(define (value? v) + (or (number? v) (boolean? v))) + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /] ['% modulo] ; <----------- !!! + ['= =] ['> >] ['>= >=] ['< <] ['<= <=] + ['and (lambda (x y) (and x y))] + ['or (lambda (x y) (or x y))])) + +(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))])) + +(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 diff --git a/semestr-2/racket/lista6/lista8/zad1.rkt b/semestr-2/racket/lista6/lista8/zad1.rkt new file mode 100644 index 0000000..1cd6b0b --- /dev/null +++ b/semestr-2/racket/lista6/lista8/zad1.rkt @@ -0,0 +1,104 @@ +#lang racket + +; Do let-env.rkt dodajemy wartosci boolowskie +; +; 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 if-expr (eb et ef) #: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))] + [(if-expr eb et ef) ; <--------------------------------------- !!! + (and (expr? eb) (expr? et) (expr? ef))] + [_ false])) + +(define (parse q) + (cond + [(number? q) (const q)] + [(eq? q 'true) (const true)] ; <---------------------------- !!! + [(eq? q 'false) (const false)] ; <---------------------------- !!! + [(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) 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) 'and)) + (if-expr (parse (second q)) + (parse (third q)) + (const false))] + [(and (list? q) (eq? (length q) 3) (eq? (first q) 'or)) + (if-expr (parse (second q)) + (const true) + (parse (third q)))] + [(and (list? q) (eq? (length q) 3) (symbol? (first q))) + (binop (first q) + (parse (second q)) + (parse (third q)))])) + +(define (test-parse) (parse '(let [x (+ 2 2)] (+ x 1)))) + +; ---------- ; +; Srodowiska ; +; ---------- ; + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; Ewaluacja ; +; --------- ; + +(define (value? v) + (or (number? v) (boolean? v))) + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /] ['% modulo] ; <----------- !!! + ['= =] ['> >] ['>= >=] ['< <] ['<= <=])) + +(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))])) + +(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 diff --git a/semestr-2/racket/lista6/lista8/zad4.bak b/semestr-2/racket/lista6/lista8/zad4.bak new file mode 100644 index 0000000..503099d --- /dev/null +++ b/semestr-2/racket/lista6/lista8/zad4.bak @@ -0,0 +1,114 @@ +#lang racket + +; Do boolean.rkt dodajemy pary +; +; 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 if-expr (eb et ef) #:transparent) +(struct cons-expr (e1 e2) #:transparent) ; <------------------- !!! +(struct car-expr (e) #:transparent) ; <------------------- !!! +(struct cdr-expr (e) #: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))] + [(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)] ; <---------------------------------- !!! + [_ false])) + +(define (parse q) + (cond + [(number? q) (const q)] + [(eq? q 'true) (const true)] + [(eq? q 'false) (const false)] + [(symbol? q) (var-expr 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) 4) (eq? (first q) 'if)) + (if-expr (parse (second q)) + (parse (third q)) + (parse (fourth q)))] + [(and (list? q) (eq? (length q) 3) (symbol? (first q))) + (binop (first q) + (parse (second q)) + (parse (third q)))])) + +(define (test-parse) (parse '(let [x (+ 2 2)] (+ x 1)))) + +; ---------- ; +; Srodowiska ; +; ---------- ; + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; Ewaluacja ; +; --------- ; + +(define (value? v) + (or (number? v) + (boolean? v) + (and (pair? v) (value? (car v)) (value? (cdr v))))) + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /] ['% modulo] + ['= =] ['> >] ['>= >=] ['< <] ['<= <=] + ['and (lambda (x y) (and x y))] + ['or (lambda (x y) (or x y))])) + +(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))] + [(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))])) ; <------------------- !!! + +(define (eval e) (eval-env e env-empty)) + +(define program + '(car (if true (cons 1 2) false))) + +(define (test-eval) (eval (parse program)))
\ No newline at end of file diff --git a/semestr-2/racket/lista6/lista8/zad4.rkt b/semestr-2/racket/lista6/lista8/zad4.rkt new file mode 100644 index 0000000..7934435 --- /dev/null +++ b/semestr-2/racket/lista6/lista8/zad4.rkt @@ -0,0 +1,118 @@ +#lang racket + +; Do boolean.rkt dodajemy pary +; +; 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 if-expr (eb et ef) #:transparent) +(struct cons-expr (e1 e2) #:transparent) ; <------------------- !!! +(struct car-expr (e) #:transparent) ; <------------------- !!! +(struct cdr-expr (e) #:transparent) ; <------------------- !!! +(struct is-pair (e) #: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))] + [(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)] ; <---------------------------------- !!! + [(is-pair e) (expr? e)] + [_ false])) + +(define (parse q) + (cond + [(number? q) (const q)] + [(eq? q 'true) (const true)] + [(eq? q 'false) (const false)] + [(symbol? q) (var-expr 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) 4) (eq? (first q) 'if)) + (if-expr (parse (second q)) + (parse (third q)) + (parse (fourth q)))] + [(and (list? q) (eq? (length q) 3) (symbol? (first q))) + (binop (first q) + (parse (second q)) + (parse (third q)))] + [(and (list? q) (eq? (length q) 2) (eq? (first q) 'pair?)) + (is-pair (parse (second q)))])) + +(define (test-parse) (parse '(let [x (+ 2 2)] (+ x 1)))) + +; ---------- ; +; Srodowiska ; +; ---------- ; + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; Ewaluacja ; +; --------- ; + +(define (value? v) + (or (number? v) + (boolean? v) + (and (pair? v) (value? (car v)) (value? (cdr v))))) + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /] ['% modulo] + ['= =] ['> >] ['>= >=] ['< <] ['<= <=] + ['and (lambda (x y) (and x y))] + ['or (lambda (x y) (or x y))])) + +(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))] + [(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))] ; <------------------- !!! + [(is-pair e) (cons? (eval-env e env))])) +(define (eval e) (eval-env e env-empty)) + +(define program + '(car (if true (cons 1 2) false))) + +(define (test-eval) (eval (parse program)))
\ No newline at end of file diff --git a/semestr-2/racket/lista6/lista8/zad5.bak b/semestr-2/racket/lista6/lista8/zad5.bak new file mode 100644 index 0000000..6f1f7b4 --- /dev/null +++ b/semestr-2/racket/lista6/lista8/zad5.bak @@ -0,0 +1 @@ +#lang racket diff --git a/semestr-2/racket/lista6/lista8/zad5.rkt b/semestr-2/racket/lista6/lista8/zad5.rkt new file mode 100644 index 0000000..721f5bf --- /dev/null +++ b/semestr-2/racket/lista6/lista8/zad5.rkt @@ -0,0 +1,151 @@ +#lang racket + +; Do list.rkt dodajemy procedury +; +; Miejsca, ktore sie zmienily oznaczone sa przez !!! + +; --------- ; +; Wyrazenia ; +; --------- ; + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) +(struct unop (op e) #:transparent) +(struct var-expr (id) #:transparent) +(struct let-expr (id e1 e2) #:transparent) +(struct if-expr (eb et ef) #:transparent) +(struct cons-expr (e1 e2) #:transparent) +(struct null-expr () #:transparent) +(struct null?-expr (e) #:transparent) +(struct app (f e) #:transparent) ; <------------------ !!! +(struct lam (id e) #: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))] + [(if-expr eb et ef) + (and (expr? eb) (expr? et) (expr? ef))] + [(cons-expr e1 e2) (and (expr? e1) (expr? e2))] + [(null-expr) true] + [(null?-expr e) (expr? e)] + [(app f e) (and (expr? f) (expr? e))] ; <--------------------- !!! + [(lam id e) (and (symbol? id) (expr? e))] ; <----------------- !!! + [_ 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? (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) 3) (eq? (first q) 'let)) + (let-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)))] + [(and (list? q) (eq? (length q) 2) (symbol? (first q))) + (unop (first q) (parse (second 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 environ (xs) #:transparent) + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; 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))) ; <---------------------------------------------- !!! + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /] ['% modulo] + ['= =] ['> >] ['>= >=] ['< <] ['<= <=] + ['and (lambda (x y) (and x y))] + ['or (lambda (x y) (or x y))] + ['not not] ['car car] ['cdr cdr] + [_ false])) ; <--------------------------------------- !!! + +(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))] + [(unop op e) ((op->proc op) (eval-env e 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))] + [(cons-expr e1 e2) (cons (eval-env e1 env) + (eval-env e2 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 + '(let [twice (lambda (f x) (f (f x)))] + (let [inc (lambda (x) (+ 1 x))] + (twice twice twice twice inc 1)))) + + +(define (test-eval) (eval (parse program)))
\ No newline at end of file diff --git a/semestr-2/racket/lista6/lista8/zad6.bak b/semestr-2/racket/lista6/lista8/zad6.bak new file mode 100644 index 0000000..721f5bf --- /dev/null +++ b/semestr-2/racket/lista6/lista8/zad6.bak @@ -0,0 +1,151 @@ +#lang racket + +; Do list.rkt dodajemy procedury +; +; Miejsca, ktore sie zmienily oznaczone sa przez !!! + +; --------- ; +; Wyrazenia ; +; --------- ; + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) +(struct unop (op e) #:transparent) +(struct var-expr (id) #:transparent) +(struct let-expr (id e1 e2) #:transparent) +(struct if-expr (eb et ef) #:transparent) +(struct cons-expr (e1 e2) #:transparent) +(struct null-expr () #:transparent) +(struct null?-expr (e) #:transparent) +(struct app (f e) #:transparent) ; <------------------ !!! +(struct lam (id e) #: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))] + [(if-expr eb et ef) + (and (expr? eb) (expr? et) (expr? ef))] + [(cons-expr e1 e2) (and (expr? e1) (expr? e2))] + [(null-expr) true] + [(null?-expr e) (expr? e)] + [(app f e) (and (expr? f) (expr? e))] ; <--------------------- !!! + [(lam id e) (and (symbol? id) (expr? e))] ; <----------------- !!! + [_ 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? (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) 3) (eq? (first q) 'let)) + (let-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)))] + [(and (list? q) (eq? (length q) 2) (symbol? (first q))) + (unop (first q) (parse (second 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 environ (xs) #:transparent) + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; 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))) ; <---------------------------------------------- !!! + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /] ['% modulo] + ['= =] ['> >] ['>= >=] ['< <] ['<= <=] + ['and (lambda (x y) (and x y))] + ['or (lambda (x y) (or x y))] + ['not not] ['car car] ['cdr cdr] + [_ false])) ; <--------------------------------------- !!! + +(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))] + [(unop op e) ((op->proc op) (eval-env e 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))] + [(cons-expr e1 e2) (cons (eval-env e1 env) + (eval-env e2 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 + '(let [twice (lambda (f x) (f (f x)))] + (let [inc (lambda (x) (+ 1 x))] + (twice twice twice twice inc 1)))) + + +(define (test-eval) (eval (parse program)))
\ No newline at end of file diff --git a/semestr-2/racket/lista6/lista8/zad6.rkt b/semestr-2/racket/lista6/lista8/zad6.rkt new file mode 100644 index 0000000..c7ea9f0 --- /dev/null +++ b/semestr-2/racket/lista6/lista8/zad6.rkt @@ -0,0 +1,171 @@ +#lang racket + +; Do list.rkt dodajemy procedury +; +; Miejsca, ktore sie zmienily oznaczone sa przez !!! + +; --------- ; +; Wyrazenia ; +; --------- ; + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) +(struct unop (op e) #:transparent) +(struct var-expr (id) #:transparent) +(struct let-expr (id e1 e2) #:transparent) +(struct if-expr (eb et ef) #:transparent) +(struct cons-expr (e1 e2) #:transparent) +(struct null-expr () #:transparent) +(struct null?-expr (e) #:transparent) +(struct app (f e) #:transparent) ; <------------------ !!! +(struct lam (id e) #:transparent) ; <------------------ !!! + +(define (expr? e) + (match e + [(const n) (or (number? n) (boolean? n))] + [(unop op e) (and (symbol? op) (expr? e))] + [(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))] + [(if-expr eb et ef) + (and (expr? eb) (expr? et) (expr? ef))] + [(cons-expr e1 e2) (and (expr? e1) (expr? e2))] + [(null-expr) true] + [(null?-expr e) (expr? e)] + [(app f e) (and (expr? f) (expr? e))] ; <--------------------- !!! + [(lam id e) (and (symbol? id) (expr? e))] ; <----------------- !!! + [_ false])) + +(define (cedar? f) + (let ((letters (string->list (symbol->string f)))) + (and (> (length letters) 2) + (eq? (first letters) #\c) + (eq? (first (reverse letters)) #\r) + (andmap (lambda (x) (or (eq? x #\a) (eq? x #\d))) + (cdr letters))))) + +(define (get-cedar letters xs) + (cond [(eq? (car letters) #\r) xs] + [(eq? (car letters) #\a) (unop 'car (get-cedar (cdr letters) xs))] + [(eq? (car letters) #\d) (unop 'cdr (get-cedar (cdr letters) xs))])) + +(define (cedar f xs) + (let ((letters (string->list (symbol->string f)))) + (get-cedar (cdr (reverse letters)) xs))) + +(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? (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) 3) (eq? (first q) 'let)) + (let-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) (eq? (length q) 2) (symbol? (first q)) + (cedar? (first q))) + (cedar (first q) (parse (second 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)))] + [(and (list? q) (eq? (length q) 2) (symbol? (first q))) + (unop (first q) (parse (second 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 environ (xs) #:transparent) + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; 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))) ; <---------------------------------------------- !!! + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /] ['% modulo] + ['= =] ['> >] ['>= >=] ['< <] ['<= <=] + ['and (lambda (x y) (and x y))] + ['or (lambda (x y) (or x y))] + ['not not] ['car car] ['cdr cdr] + [_ false])) ; <--------------------------------------- !!! + +(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))] + [(unop op e) ((op->proc op) (eval-env e 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))] + [(cons-expr e1 e2) (cons (eval-env e1 env) + (eval-env e2 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 + '(let [twice (lambda (f x) (f (f x)))] + (let [inc (lambda (x) (+ 1 x))] + (twice twice twice twice inc 1)))) + + +(define (test-eval) (eval (parse program)))
\ No newline at end of file diff --git a/semestr-2/racket/lista6/lista8/zadanie.rkt b/semestr-2/racket/lista6/lista8/zadanie.rkt new file mode 100644 index 0000000..0960f21 --- /dev/null +++ b/semestr-2/racket/lista6/lista8/zadanie.rkt @@ -0,0 +1,98 @@ +#lang racket + +; Do let-env.rkt dodajemy wartosci boolowskie +; +; 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 if-expr (eb et ef) #: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))] + [(if-expr eb et ef) ; <--------------------------------------- !!! + (and (expr? eb) (expr? et) (expr? ef))] + [_ false])) + +(define (parse q) + (cond + [(number? q) (const q)] + [(eq? q 'true) (const true)] ; <---------------------------- !!! + [(eq? q 'false) (const false)] ; <---------------------------- !!! + [(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) 4) (eq? (first q) 'if)) ; <--- !!! + (if-expr (parse (second q)) + (parse (third q)) + (parse (fourth q)))] + [(and (list? q) (eq? (length q) 3) (symbol? (first q))) + (binop (first q) + (parse (second q)) + (parse (third q)))])) + +(define (test-parse) (parse '(let [x (+ 2 2)] (+ x 1)))) + +; ---------- ; +; Srodowiska ; +; ---------- ; + +(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 "Unknown identifier" x)] + [(eq? x (car (car xs))) (cdr (car xs))] + [else (assoc-lookup (cdr xs))])) + (assoc-lookup (environ-xs env))) + +; --------- ; +; Ewaluacja ; +; --------- ; + +(define (value? v) + (or (number? v) (boolean? v))) + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /] ['% modulo] ; <----------- !!! + ['= =] ['> >] ['>= >=] ['< <] ['<= <=] + ['and (lambda (x y) (and x y))] + ['or (lambda (x y) (or x y))])) + +(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))])) + +(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 diff --git a/semestr-2/racket/lista6/solution.bak b/semestr-2/racket/lista6/solution.bak new file mode 100644 index 0000000..0805991 --- /dev/null +++ b/semestr-2/racket/lista6/solution.bak @@ -0,0 +1,27 @@ +#lang racket + +(provide (struct-out complex) parse eval) + +(struct complex (re im) #:transparent) + +(define value? + complex?) + +;; Ponizej znajduje sie interpreter zwyklych wyrazen arytmetycznych. +;; Zadanie to zmodyfikowac go tak, by dzialal z liczbami zespolonymi. + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /])) + +(define (eval e) + (match e + [(const n) n] + [(binop op l r) ((op->proc op) (eval l) (eval r))])) + +(define (parse q) + (cond [(number? q) (const q)] + [(and (list? q) (eq? (length q) 3) (symbol? (first q))) + (binop (first q) (parse (second q)) (parse (third q)))]))
\ No newline at end of file diff --git a/semestr-2/racket/lista6/solution.rkt b/semestr-2/racket/lista6/solution.rkt new file mode 100644 index 0000000..59bdecd --- /dev/null +++ b/semestr-2/racket/lista6/solution.rkt @@ -0,0 +1,73 @@ +#lang racket + +(provide (struct-out complex) parse eval) + +(struct complex (re im) #:transparent) + +(define value? + complex?) + +(define (comp-plus x y) + (let ((x-re (complex-re x)) + (x-im (complex-im x)) + (y-re (complex-re y)) + (y-im (complex-im y))) + (complex (+ x-re y-re) (+ x-im y-im)))) + +(define (comp-minus x y) + (let ((x-re (complex-re x)) + (x-im (complex-im x)) + (y-re (complex-re y)) + (y-im (complex-im y))) + (complex (- x-re y-re) (- x-im y-im)))) + +(define (comp-mult x y) + (let ((x-re (complex-re x)) + (x-im (complex-im x)) + (y-re (complex-re y)) + (y-im (complex-im y))) + (complex (- (* x-re y-re) (* x-im y-im)) (+ (* x-re y-im) (* x-im y-re))))) + +(define (comp-mod2 x) + (let ((x-re (complex-re x)) + (x-im (complex-im x))) + (complex (+ (* x-re x-re) (* x-im x-im)) 0))) + +(define (comp-mod x) + (let ((mod2 (comp-mod2 x)) + (x-re (complex-re x))) + (complex (sqrt x-re) 0))) + +(define (comp-div x y) + (let* ((mod2 (complex-re (comp-mod2 y))) + (x-re (complex-re x)) + (x-im (complex-im x)) + (y-re (complex-re y)) + (y-im (complex-im y)) + (real (+ (* x-re y-re) (* x-im y-im))) + (imag (- (* x-im y-re) (* x-re y-im)))) + (complex (/ real mod2) (/ imag mod2)))) + + +;; Ponizej znajduje sie interpreter zwyklych wyrazen arytmetycznych. +;; Zadanie to zmodyfikowac go tak, by dzialal z liczbami zespolonymi. + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) + +(define (imaginary-unit? c) + (eq? c 'i)) + +(define (op->proc op) + (match op ['+ comp-plus] ['- comp-minus] ['* comp-mult] ['/ comp-div])) + +(define (eval e) + (match e + [(const n) n] + [(binop op l r) ((op->proc op) (eval l) (eval r))])) + +(define (parse q) + (cond [(number? q) (const (complex q 0))] + [(imaginary-unit? q) (const (complex 0 1))] + [(and (list? q) (eq? (length q) 3) (symbol? (first q))) + (binop (first q) (parse (second q)) (parse (third q)))]))
\ No newline at end of file diff --git a/semestr-2/racket/lista6/zad11/solution.bak b/semestr-2/racket/lista6/zad11/solution.bak new file mode 100644 index 0000000..f449481 --- /dev/null +++ b/semestr-2/racket/lista6/zad11/solution.bak @@ -0,0 +1,36 @@ +#lang racket + +(provide (struct-out const) (struct-out binop) rpn->arith) + +;; ------------------------------- +;; Wyrazenia w odwr. not. polskiej +;; ------------------------------- + +(define (rpn-expr? e) + (and (list? e) + (pair? e) + (andmap (lambda (x) (or (number? x) (member x '(+ - * /)))) + e))) + +;; ---------------------- +;; Wyrazenia arytmetyczne +;; ---------------------- + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) + +(define (arith-expr? e) + (match e + [(const n) (number? n)] + [(binop op l r) + (and (symbol? op) (arith-expr? l) (arith-expr? r))] + [_ false])) + +;; ---------- +;; Kompilacja +;; ---------- + +(define (rpn->arith e) + (error "TODO: Uzupelnij tutaj")) + +; Mozesz tez dodac jakies procedury pomocnicze i testy
\ No newline at end of file diff --git a/semestr-2/racket/lista6/zad11/solution.rkt b/semestr-2/racket/lista6/zad11/solution.rkt new file mode 100644 index 0000000..a44afe4 --- /dev/null +++ b/semestr-2/racket/lista6/zad11/solution.rkt @@ -0,0 +1,58 @@ +#lang racket + +(provide (struct-out const) (struct-out binop) rpn->arith) + +;; ------------------------------- +;; Wyrazenia w odwr. not. polskiej +;; ------------------------------- + +(define (rpn-expr? e) + (and (list? e) + (pair? e) + (andmap (lambda (x) (or (number? x) (member x '(+ - * /)))) + e))) + +;; ---------------------- +;; Wyrazenia arytmetyczne +;; ---------------------- + +(struct const (val) #:transparent) +(struct binop (op l r) #:transparent) + +(define (arith-expr? e) + (match e + [(const n) (number? n)] + [(binop op l r) + (and (symbol? op) (arith-expr? l) (arith-expr? r))] + [_ false])) + +;; ---------- +;; Kompilacja +;; ---------- + +(struct stack (xs)) + +(define empty-stack (stack null)) +(define (empty-stack? s) (null? (stack-xs s))) +(define (top s) (car (stack-xs s))) +(define (push a s) (stack (cons a (stack-xs s)))) +(define (pop s) (stack (cdr (stack-xs s)))) + +(define (op->proc op) + (match op ['+ +] ['- -] ['* *] ['/ /])) + +(define (eval-am e s) + (cond [(null? e) + (top s)] + [(number? (car e)) + (eval-am (cdr e) (push (const (car e)) s))] + [(symbol? (car e)) + (eval-am (cdr e) + (push (binop (car e) (top (pop s)) (top s)) + (pop (pop s))))])) + +(define (rpn->arith e) + (eval-am e empty-stack)) + + +; Mozesz tez dodac jakies procedury pomocnicze i testy
\ No newline at end of file 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))
diff --git a/semestr-2/racket/rac.rkt b/semestr-2/racket/rac.rkt new file mode 100644 index 0000000..8300208 --- /dev/null +++ b/semestr-2/racket/rac.rkt @@ -0,0 +1,371 @@ +#reader(lib"read.ss""wxme")WXME0109 ## +#| + This file uses the GRacket editor format. + Open this file in DrRacket version 7.6 or later to read it. + + Most likely, it was created by saving a program in DrRacket, + and it probably contains a program with non-text elements + (such as images or comment boxes). + + http://racket-lang.org/ +|# + 33 7 #"wxtext\0" +3 1 6 #"wxtab\0" +1 1 8 #"wximage\0" +2 0 8 #"wxmedia\0" +4 1 34 #"(lib \"syntax-browser.ss\" \"mrlib\")\0" +1 0 36 #"(lib \"cache-image-snip.ss\" \"mrlib\")\0" +1 0 68 +(0 + #"((lib \"image-core.ss\" \"mrlib\") (lib \"image-core-wxme.rkt\" \"mr" + #"lib\"))\0" +) 1 0 16 #"drscheme:number\0" +3 0 44 #"(lib \"number-snip.ss\" \"drscheme\" \"private\")\0" +1 0 36 #"(lib \"comment-snip.ss\" \"framework\")\0" +1 0 93 +(1 + #"((lib \"collapsed-snipclass.ss\" \"framework\") (lib \"collapsed-sni" + #"pclass-wxme.ss\" \"framework\"))\0" +) 0 0 43 #"(lib \"collapsed-snipclass.ss\" \"framework\")\0" +0 0 19 #"drscheme:sexp-snip\0" +0 0 29 #"drscheme:bindings-snipclass%\0" +1 0 101 +(2 + #"((lib \"ellipsis-snip.rkt\" \"drracket\" \"private\") (lib \"ellipsi" + #"s-snip-wxme.rkt\" \"drracket\" \"private\"))\0" +) 2 0 88 +(3 + #"((lib \"pict-snip.rkt\" \"drracket\" \"private\") (lib \"pict-snip.r" + #"kt\" \"drracket\" \"private\"))\0" +) 0 0 55 +#"((lib \"snip.rkt\" \"pict\") (lib \"snip-wxme.rkt\" \"pict\"))\0" +1 0 34 #"(lib \"bullet-snip.rkt\" \"browser\")\0" +0 0 25 #"(lib \"matrix.ss\" \"htdp\")\0" +1 0 22 #"drscheme:lambda-snip%\0" +1 0 29 #"drclickable-string-snipclass\0" +0 0 26 #"drracket:spacer-snipclass\0" +0 0 57 +#"(lib \"hrule-snip.rkt\" \"macro-debugger\" \"syntax-browser\")\0" +1 0 26 #"drscheme:pict-value-snip%\0" +0 0 45 #"(lib \"image-snipr.ss\" \"slideshow\" \"private\")\0" +1 0 38 #"(lib \"pict-snipclass.ss\" \"slideshow\")\0" +2 0 55 #"(lib \"vertical-separator-snip.ss\" \"stepper\" \"private\")\0" +1 0 18 #"drscheme:xml-snip\0" +1 0 31 #"(lib \"xml-snipclass.ss\" \"xml\")\0" +1 0 21 #"drscheme:scheme-snip\0" +2 0 34 #"(lib \"scheme-snipclass.ss\" \"xml\")\0" +1 0 10 #"text-box%\0" +1 0 32 #"(lib \"text-snipclass.ss\" \"xml\")\0" +1 0 1 6 #"wxloc\0" + 0 0 64 0 1 #"\0" +0 75 1 #"\0" +0 10 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 9 +#"Standard\0" +0 75 12 #"Courier New\0" +0 26 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 24 +#"framework:default-color\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 15 +#"text:ports out\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1.0 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 255 0 0 0 0 0 -1 +-1 2 15 #"text:ports err\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 17 +#"text:ports value\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1.0 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 34 139 34 0 0 0 -1 +-1 2 27 #"Matching Parenthesis Style\0" +0 -1 1 #"\0" +1.0 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 34 139 34 0 0 0 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 37 +#"framework:syntax-color:scheme:symbol\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 38 +#"framework:syntax-color:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +38 #"framework:syntax-color:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 37 +#"framework:syntax-color:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 35 +#"framework:syntax-color:scheme:text\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 39 +#"framework:syntax-color:scheme:constant\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 49 +#"framework:syntax-color:scheme:hash-colon-keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 42 +#"framework:syntax-color:scheme:parenthesis\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 36 +#"framework:syntax-color:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 36 +#"framework:syntax-color:scheme:other\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 16 +#"Misspelled Text\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 +38 #"drracket:check-syntax:lexically-bound\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 28 +#"drracket:check-syntax:set!d\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 37 +#"drracket:check-syntax:unused-require\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 36 +#"drracket:check-syntax:free-variable\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 31 +#"drracket:check-syntax:imported\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 47 +#"drracket:check-syntax:my-obligation-style-pref\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 116 0 0 0 0 -1 -1 2 50 +#"drracket:check-syntax:their-obligation-style-pref\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 116 0 0 0 0 -1 -1 2 48 +#"drracket:check-syntax:unk-obligation-style-pref\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 139 142 28 0 0 0 -1 -1 2 +49 #"drracket:check-syntax:both-obligation-style-pref\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 139 142 28 0 0 0 -1 -1 2 +26 #"plt:htdp:test-coverage-on\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 2 27 +#"plt:htdp:test-coverage-off\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 4 1 +#"\0" +0 70 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 4 4 #"XML\0" +0 70 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 2 37 #"plt:module-language:test-coverage-on\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 38 +#"plt:module-language:test-coverage-off\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 93 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 0 36 +#"mrlib/syntax-browser:subtitle-color\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 36 36 140 255 255 255 -1 +-1 0 42 #"mrlib/syntax-browser:focused-syntax-color\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 34 139 34 255 255 255 -1 +-1 4 1 #"\0" +0 71 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 4 1 #"\0" +0 -1 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1.0 1.0 1.0 0 0 255 0 0 0 -1 +-1 4 1 #"\0" +0 71 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1.0 1.0 1.0 0 0 255 0 0 0 -1 +-1 4 1 #"\0" +0 71 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 0 100 0 0 0 0 -1 +-1 4 1 #"\0" +0 71 1 #"\0" +1.0 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 255 0 0 0 0 0 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1.0 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1.0 1.0 1.0 148 0 211 0 0 0 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1.0 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1.0 1.0 1.0 0 0 255 0 0 0 -1 +-1 0 1 #"\0" +0 -1 1 #"\0" +0 12 -1 -1 -1 -1 -1 -1 0 0 1 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 2 1 #"\0" +0 -1 1 #"\0" +0 12 -1 -1 -1 -1 -1 -1 0 0 1 0 0 0 1.0 1.0 1.0 1.0 1.0 1.0 0 0 0 0 0 0 +-1 -1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 200 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1.0 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 0 -1 -1 + 0 122 0 28 3 12 #"#lang racket" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 6 #"define" +0 0 24 3 2 #" (" +0 0 14 3 6 #"fringe" +0 0 24 3 1 #" " +0 0 14 3 4 #"tree" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 15 3 4 #"cond" +0 0 24 3 3 #" ((" +0 0 14 3 5 #"null?" +0 0 24 3 1 #" " +0 0 14 3 4 #"tree" +0 0 24 3 2 #") " +0 0 14 3 4 #"null" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 10 #" ((" +0 0 14 3 3 #"not" +0 0 24 3 2 #" (" +0 0 14 3 5 #"pair?" +0 0 24 3 1 #" " +0 0 14 3 4 #"tree" +0 0 24 3 4 #")) (" +0 0 14 3 4 #"list" +0 0 24 3 1 #" " +0 0 14 3 4 #"tree" +0 0 24 3 2 #"))" +0 0 24 29 1 #"\n" +0 0 24 3 9 #" (" +0 0 14 3 4 #"else" +0 0 24 3 2 #" (" +0 0 14 3 6 #"append" +0 0 24 3 2 #" (" +0 0 14 3 6 #"fringe" +0 0 24 3 2 #" (" +0 0 14 3 3 #"car" +0 0 24 3 1 #" " +0 0 14 3 4 #"tree" +0 0 24 3 2 #"))" +0 0 24 29 1 #"\n" +0 0 24 3 23 #" (" +0 0 14 3 6 #"fringe" +0 0 24 3 2 #" (" +0 0 14 3 3 #"cdr" +0 0 24 3 1 #" " +0 0 14 3 4 #"tree" +0 0 24 3 6 #"))))))" +0 0 24 29 1 #"\n" +0 0 24 29 1 #"\n" +0 0 24 3 1 #"(" +0 0 15 3 6 #"define" +0 0 24 3 2 #" (" +0 0 14 3 7 #"subsets" +0 0 24 3 1 #" " +0 0 14 3 1 #"s" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 3 #" (" +0 0 14 3 2 #"if" +0 0 24 3 2 #" (" +0 0 14 3 5 #"null?" +0 0 24 3 1 #" " +0 0 14 3 1 #"s" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 7 #" (" +0 0 14 3 4 #"list" +0 0 24 3 1 #" " +0 0 14 3 4 #"null" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 7 #" (" +0 0 15 3 3 #"let" +0 0 24 3 3 #" ((" +0 0 14 3 4 #"rest" +0 0 24 3 2 #" (" +0 0 14 3 7 #"subsets" +0 0 24 3 2 #" (" +0 0 14 3 3 #"cdr" +0 0 24 3 1 #" " +0 0 14 3 1 #"s" +0 0 24 3 4 #"))))" +0 0 24 29 1 #"\n" +0 0 24 3 9 #" (" +0 0 14 3 7 #"display" +0 0 24 3 1 #" " +0 0 14 3 1 #"s" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 9 #" (" +0 0 14 3 7 #"newline" +0 0 24 3 1 #")" +0 0 24 29 1 #"\n" +0 0 24 3 9 #" (" +0 0 14 3 6 #"append" +0 0 24 3 1 #" " +0 0 14 3 4 #"rest" +0 0 24 3 2 #" (" +0 0 14 3 3 #"map" +0 0 24 3 2 #" (" +0 0 15 3 6 #"lambda" +0 0 24 3 2 #" (" +0 0 14 3 1 #"x" +0 0 24 3 3 #") (" +0 0 14 3 4 #"cons" +0 0 24 3 2 #" (" +0 0 14 3 3 #"car" +0 0 24 3 1 #" " +0 0 14 3 1 #"s" +0 0 24 3 2 #") " +0 0 14 3 1 #"x" +0 0 24 3 3 #")) " +0 0 14 3 4 #"rest" +0 0 24 3 5 #")))))" +0 0 24 29 1 #"\n" +0 0 24 3 2 #" " +0 0 diff --git a/semestr-2/racket/solution.rkt b/semestr-2/racket/solution.rkt new file mode 100644 index 0000000..3643668 --- /dev/null +++ b/semestr-2/racket/solution.rkt @@ -0,0 +1,14 @@ +#lang racket + +(provide heapsort) (require "leftist.rkt") + +(define (heapsort xs) + (define (create-heap xs res) + (if (null? xs) + res + (create-heap (cdr xs) (heap-insert (cons (car xs) (car xs)) res)))) + (define (heap-to-list h) + (if (heap-empty? h) + null + (cons (elem-val (heap-min h)) (heap-to-list (heap-pop h))))) + (heap-to-list (create-heap xs empty-heap)))
\ No newline at end of file |