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

---
 Semestr 2/racket/l14z22/solution.bak | 70 +++++++++++++++++++++++++++++
 Semestr 2/racket/l14z22/solution.rkt | 87 ++++++++++++++++++++++++++++++++++++
 2 files changed, 157 insertions(+)
 create mode 100644 Semestr 2/racket/l14z22/solution.bak
 create mode 100644 Semestr 2/racket/l14z22/solution.rkt

(limited to 'Semestr 2/racket/l14z22')

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)))
+
+
-- 
cgit v1.2.3