A nonogram is a puzzle that provides
numeric clues used to fill in a grid of cells,
establishing for each cell whether it is filled or not.
The puzzle solution is typically a picture of some kind.

Each row and column of a rectangular grid is annotated with the lengths
of its distinct runs of occupied cells.
Using only these lengths you should find one valid configuration
of empty and occupied cells, or show a failure message.

Example
Problem:                 Solution:

. . . . . . . .  3       . # # # . . . .  3
. . . . . . . .  2 1     # # . # . . . .  2 1
. . . . . . . .  3 2     . # # # . . # #  3 2
. . . . . . . .  2 2     . . # # . . # #  2 2
. . . . . . . .  6       . . # # # # # #  6
. . . . . . . .  1 5     # . # # # # # .  1 5
. . . . . . . .  6       # # # # # # . .  6
. . . . . . . .  1       . . . . # . . .  1
. . . . . . . .  2       . . . # # . . .  2
1 3 1 7 5 3 4 3          1 3 1 7 5 3 4 3
2 1 5 1                  2 1 5 1
The problem above could be represented by two lists of lists:

x = [[3], [2,1], [3,2], [2,2], [6], [1,5], [6], [1], [2]]
y = [[1,2], [3,1], [1,5], [7,1], [5], [3], [4], [3]]
A more compact representation of the same problem uses strings,
where the letters represent the numbers, A=1, B=2, etc:

x = "C BA CB BB F AE F A B"
y = "AB CA AE GA E C D C"
Task
For this task, try to solve the 4 problems below, read from a “nonogram_problems.txt” file that has this content
(the blank lines are separators):

C BA CB BB F AE F A B
AB CA AE GA E C D C

F CAC ACAC CN AAA AABB EBB EAA ECCC HCCC
D D AE CD AE A DA BBB CC AAB BAA AAB DA AAB AAA BAB AAA CD BBA DA

CA BDA ACC BD CCAC CBBAC BBBBB BAABAA ABAD AABB BBH BBBD ABBAAA CCEA AACAAB BCACC ACBH DCH ADBE ADBB DBE ECE DAA DB CC
BC CAC CBAB BDD CDBDE BEBDF ADCDFA DCCFB DBCFC ABDBA BBF AAF BADB DBF AAAAD BDG CEF CBDB BBB FC

E BCB BEA BH BEK AABAF ABAC BAA BFB OD JH BADCF Q Q R AN AAN EI H G
E CB BAB AAA AAA AC BB ACC ACCA AGB AIA AJ AJ ACE AH BAF CAG DAG FAH FJ GJ ADK ABK BL CM
Extra credit: generate nonograms with unique solutions, of desired height and width.



This task is the problem n.98 of the "99 Prolog Problems" by Werner Hett (also thanks to Paul Singleton for the idea and the examples).




 Related tasks
 Nonoblock.


See also
 Arc Consistency Algorithm
 http://www.haskell.org/haskellwiki/99_questions/Solutions/98 (Haskell)
 http://twanvl.nl/blog/haskell/Nonograms (Haskell)
 http://picolisp.com/5000/!wiki?99p98 (PicoLisp)


(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 ())))