From d7f6da737335aaf87ac1d5c5ff283bb0d7a5507f Mon Sep 17 00:00:00 2001
From: Thomas White <taw@physics.org>
Date: Sun, 3 Apr 2022 17:09:09 +0200
Subject: Clean up (sort of)

---
 sudoku.scm | 141 +++++++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 95 insertions(+), 46 deletions(-)

diff --git a/sudoku.scm b/sudoku.scm
index 965e8d2..5d9306b 100644
--- a/sudoku.scm
+++ b/sudoku.scm
@@ -1,19 +1,17 @@
 (use-modules
   (srfi srfi-1)
+  (srfi srfi-26)
+  (ice-9 match)
   (sat solver)
   (sat helpers))
 
-;; Board indices: column row value
-(define board-size 9)
-
-
 (define (get-value board vals col row)
   (1+
    (find
      (lambda (possible-value)
        (array-ref vals
                   (array-ref board col row possible-value)))
-     (iota board-size))))
+     (iota (biggest-value board)))))
 
 
 (define (set-initial-value board col row val)
@@ -25,53 +23,106 @@
                  (1- val)))))
 
 
-(let ((board (make-array #f
-                         board-size
-                         board-size
-                         board-size)))
-  (array-map! board make-sat-variable)
+(define (map-for-0-to n f)
+  (map f (iota n)))
 
-  ;; No row contains duplicate values
-  (do ((row 0 (1+ row))) ((= row board-size))
-    (do ((value 0 (1+ value))) ((= value board-size))
-      (exactly-one-true
-        (map
-          (lambda (col)
-            (array-ref board col row value))
-          (iota board-size)))))
 
-  ;; No column contains duplicate values
-  (do ((col 0 (1+ col))) ((= col board-size))
-    (do ((value 0 (1+ value))) ((= value board-size))
+(define (make-row row board-size)
+  (map-for-0-to
+    board-size
+    (cut cons <> row)))
+
+
+(define (make-col col board-size)
+  (map-for-0-to
+    board-size
+    (cut cons col <>)))
+
+
+(define (rows board-size)
+  (map-for-0-to
+    board-size
+    (cut make-row <> board-size)))
+
+
+(define (cols board-size)
+  (map-for-0-to
+    board-size
+    (cut make-col <> board-size)))
+
+
+(define (make-box bcol brow box-size)
+  (let ((l '()))
+    (do ((icol 0 (1+ icol))) ((= icol box-size))
+      (do ((irow 0 (1+ irow))) ((= irow box-size))
+        (set! l (cons
+                  (cons (+ (* box-size bcol) icol)
+                        (+ (* box-size brow) irow))
+                  l))))
+    l))
+
+
+(define (boxes board-size box-size)
+  (let ((l '()))
+    (do ((bcol 0 (1+ bcol))) ((= bcol 3))
+      (do ((brow 0 (1+ brow))) ((= brow 3))
+        (set! l (cons
+                   (make-box bcol brow box-size)
+                   l))
+        ))
+    l))
+
+
+(define (biggest-value board)
+  (1+ (match
+    (array-shape board)
+    (((_ _) (_ _) (_ max-value))
+     max-value))))
+
+
+(define (unique-values board coords-list)
+  (for-each
+    (lambda (n)
       (exactly-one-true
         (map
-          (lambda (row)
-            (array-ref board col row value))
-          (iota board-size)))))
-
-  ;; No 3x3 box contains duplicate values
-  (do ((col 0 (+ 3 col))) ((= col board-size))
-    (do ((row 0 (+ 3 row))) ((= row board-size))
-      (do ((value 0 (1+ value))) ((= value board-size))
-        (exactly-one-true
-          (let ((l '()))
-            (do ((col1 0 (1+ col1))) ((= col1 3))
-              (do ((row1 0 (1+ row1))) ((= row1 3))
-                (set! l (cons (array-ref board
-                                         (+ col col1)
-                                         (+ row row1)
-                                         value)
-                              l))))
-            l)))))
+          (lambda (coord)
+            (array-ref board (car coord) (cdr coord) n))
+          coords-list)))
+    (iota (biggest-value board))))
+
+
+(define (all-unique-values board coord-lists)
+  (for-each
+    (cut unique-values board <>)
+    coord-lists))
+
+
+(define (make-board size)
+  (let ((board (make-array #f size size size)))
+    (array-map! board make-sat-variable)
+    board))
+
+
+(define (all-one-number board col row)
+  (exactly-one-true
+    (map
+      (lambda (value)
+        (array-ref board col row value))
+      (iota (biggest-value board)))))
+
+
+(let* ((board-size 9)
+       (board (make-board board-size)))
+
+  ;; The standard Sudoku rules
+  (all-unique-values board (rows board-size))
+  (all-unique-values board (cols board-size))
+  (all-unique-values board (boxes board-size 3))
 
   ;; Each position contains exactly one number
   (do ((col 0 (1+ col))) ((= col board-size))
     (do ((row 0 (1+ row))) ((= row board-size))
-      (exactly-one-true
-        (map
-          (lambda (value)
-            (array-ref board col row value))
-          (iota board-size)))))
+      (all-one-number board col row)))
 
   ;; Initially specified values
   (set-initial-value board 0 0 4)
@@ -100,8 +151,6 @@
 
   (set-initial-value board 8 0 5)
 
-
-
   (let ((vals (solve-sat)))
     (do ((row 0 (1+ row))) ((= row board-size))
       (do ((col 0 (1+ col))) ((= col board-size))
-- 
cgit v1.2.3