Data commit

Task/Nonogram-solver/Common-Lisp/nonogram-solver.lisp

@@ -0,0 +1,175 @@
+(defpackage :ac3
+  (:use :cl)
+  (:export :var
+           :domain
+           :satisfies-p
+           :constraint-possible-p
+           :ac3)
+  (:documentation "Implements the AC3 algorithm. Extend VAR with the variable
+types for your particular problem and implement SATISFIES-P and
+CONSTRAINT-POSSIBLE-P for your variables. Initialize the DOMAIN of your variables
+with unary constraints already satisfied and then pass them to AC3 in a list."))
+
+(in-package :ac3)
+
+(defclass var ()
+  ((domain :initarg :domain :accessor domain))
+  (:documentation "The base variable type from which all other
+variables should extend."))
+
+(defgeneric satisfies-p (a b va vb)
+  (:documentation "Determine if constrainted variables A and B are
+satisfied by the instantiation of their respective values VA and VB."))
+
+(defgeneric constraint-possible-p (a b)
+  (:documentation "Determine if variables A and B can even be
+checked for a binary constraint."))
+
+(defun arc-reduce (a b)
+  "Assuming A and B truly form a constraint, prune all values
+from A that do not satisfy any value in B. Return T if the domain
+of A changed by any amount, NIL otherwise."
+  (let (change)
+    (setf (domain a)
+          (loop for va in (domain a)
+             when (loop for vb in (domain b)
+                     do (when (satisfies-p a b va vb)
+                          (return t))
+                     finally (setf change t) (return nil))
+             collect va))
+    change))
+
+(defun binary-constraint-p (a b)
+  "Check if variables A and B could form a constraint, then return T
+if any of their values form a contradiction, NIL otherwise."
+  (when (constraint-possible-p a b)
+    (block found
+      (loop for va in (domain a)
+         do (loop for vb in (domain b)
+               do (unless (satisfies-p a b va vb)
+                    (return-from found t)))))))
+
+(defun ac3 (vars)
+  "Run the Arc Consistency 3 algorithm on the given set of variables.
+Assumes unary constraints have already been satisfied."
+  ;; Form a worklist of the constraints of every variable to every other variable.
+  (let ((worklist (loop for x in vars
+                     append (loop for y in vars
+                               when (and (not (eq x y))
+                                         (binary-constraint-p x y))
+                               collect (cons x y)))))
+    ;; Prune the worklist of satisfied arcs until it is empty.
+    (loop while worklist
+       do (destructuring-bind (x . y) (pop worklist)
+            (when (arc-reduce x y)
+              (if (domain x)
+                  ;; If the current arc's domain was reduced, then append any arcs it
+                  ;; is still constrained with to the end of the worklist, as they
+                  ;; need to be rechecked.
+                  (setf worklist (nconc worklist (loop for z in vars
+                                                    when (and (not (eq x z))
+                                                              (not (eq y z))
+                                                              (binary-constraint-p x z))
+                                                    collect (cons z x))))
+                  (error "No values left in ~a" x))))
+       finally (return vars))))
+
+(defpackage :nonogram
+  (:use :cl :ac3)
+  (:documentation "Utilize the AC3 package to solve nonograms."))
+
+(in-package :nonogram)
+
+(defclass line (var)
+  ((depth :initarg :depth :accessor depth))
+  (:documentation "A LINE is a variable that represents either a
+column or row of cells and all of the permutations of values those
+cells can assume"))
+
+(defmethod print-object ((o line) s)
+  (print-unreadable-object (o s :type t)
+    (with-slots (depth domain) o
+      (format s ":depth ~a :domain ~a" depth domain))))
+
+(defclass row (line) ())
+
+(defclass col (line) ())
+
+(defmethod satisfies-p ((a line) (b line) va vb)
+  (eq (aref va (depth b))
+      (aref vb (depth a))))
+
+(defmethod constraint-possible-p ((a line) (b line))
+  (not (eq (type-of a) (type-of b))))
+
+(defun make-line-domain (runs length &optional (start 0) acc)
+  "Enumerate all valid permutations of a line's values."
+  (if runs
+      (loop for i from start
+         to (- length
+               (reduce #'+ (cdr runs))
+               (length (cdr runs))
+               (car runs))
+         append (make-line-domain (cdr runs) length (+ 1 i (car runs)) (cons i acc)))
+      (list (reverse acc))))
+
+(defun make-line (type runs depth length)
+  "Create and initialize a ROW or COL instance."
+  (make-instance
+   type :depth depth :domain
+   (loop for value in (make-line-domain runs length)
+      collect (let ((arr (make-array length :initial-element nil)))
+                (loop for pos in value
+                   for run in runs
+                   do (loop for i from pos below (+ pos run)
+                         do (setf (aref arr i) t)))
+                arr))))
+
+(defun make-lines (type run-set length)
+  "Initialize a set of lines."
+  (loop for runs across run-set
+     for depth from 0
+     collect (make-line type runs depth length)))
+
+(defun nonogram (problem)
+  "Given a nonogram problem description, solve it and print the result."
+  (let* ((nrows (length (aref problem 0)))
+         (ncols (length (aref problem 1)))
+         (vars (ac3 (append (make-lines 'row (aref problem 0) ncols)
+                            (make-lines 'col (aref problem 1) nrows)))))
+    (loop for var in vars
+       while (eq 'row (type-of var))
+       do (terpri)
+         (loop for cell across (car (domain var))
+            do (format t "~a " (if cell #\# #\.))))))
+
+(defparameter *test-set*
+  '("C BA CB BB F AE F A B"
+    "AB CA AE GA E C D C"))
+
+;; Helper functions to read and parse problems from a file.
+
+(defun parse-word (word)
+  (map 'list (lambda (c) (- (digit-char-p c 36) 9)) word))
+
+(defun parse-line (line)
+  (map 'vector #'parse-word (uiop:split-string (string-upcase line))))
+
+(defun parse-nonogram (rows columns)
+  (vector (parse-line rows)
+          (parse-line columns)))
+
+(defun read-until-line (stream)
+  (loop (let ((line (read-line stream)))
+          (when (> (length (string-trim '(#\space) line)) 0)
+            (print line)
+            (return line)))))
+
+(defun solve-from-file (file)
+  (handler-case
+      (with-open-file (s file)
+        (loop
+           (terpri)
+           (nonogram (parse-nonogram (read-until-line s)
+                                     (read-until-line s)))))
+    (end-of-file ())))