diff options
Diffstat (limited to 'semestr-2/racket/l11z20/solution.rkt')
| -rw-r--r-- | semestr-2/racket/l11z20/solution.rkt | 245 |
1 files changed, 245 insertions, 0 deletions
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) + + |