Nonogram solver

Nonogram solver
You are encouraged to solve this task according to the task description, using any language you may know.

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.

[GCHQ Xmas Puzzle] is a Nonogram. They say "We pre-shaded a few cells to help people get started. Without this, the puzzle would have been slightly ambiguous, though the error correction used in QR codes means that the URL would have been recovered anyway. As a small Easter egg, the pre-shaded cells spell out “GCHQ” in Morse code."

(defpackage :ac3(:use:cl)(:export:var:domain:satisfies-p:constraint-possible-p:ac3)(:documentation"Implements the AC3 algorithm. Extend VAR with the variabletypes for your particular problem and implement SATISFIES-P andCONSTRAINT-POSSIBLE-P for your variables. Initialize the DOMAIN of your variableswith unary constraints already satisfied and then pass them to AC3 in a list."))

(defgeneric satisfies-p (a b va vb)(:documentation"Determine if constrainted variables A and B aresatisfied 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 bechecked for a binary constraint."))

(defun arc-reduce (a b)"Assuming A and B truly form a constraint, prune all valuesfrom A that do not satisfy any value in B. Return T if the domainof 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)(returnnil)) collect va)) change))

(defun binary-constraint-p (a b)"Check if variables A and B could form a constraint, then return Tif 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 varsappend(loop for y in varswhen(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 worklistdo(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 varswhen(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))))

(defclass line (var)((depth :initarg:depth:accessor depth))(:documentation"A LINE is a variable that represents either acolumn or row of cells and all of the permutations of values thosecells can assume"))

/* If all the candidates for a row have a value in common for a certain cell, then it's the only possible outcome, and all the candidates from the corresponding column need to have that value for that cell too. The ones that don't, are removed. The same for all columns. It goes back and forth, until no more candidates can be removed or a list is empty (failure). */

/* If all the candidates for a row have a value in common for a certain cell, then it's the only possible outcome, and all the candidates from the corresponding column need to have that value for that cell too. The ones that don't, are removed. The same for all columns. It goes back and forth, until no more candidates can be removed or a list is empty (failure).*/

function count_grid()integer res = length(x)*length(y) for i=1 to length(x) do for j=1 to length(y) do res -= grid[i][j]!='?' end for end for return resend function

function match_mask(string neat, string mask, integer ms, integer me) for i=ms to me do if mask[i]!='?' then if mask[i]!=neat[i] then return 0 end if end if end for return 1end function

function innr(string mask, sequence blocks, integer mi=1, string res="", string neat=mask) if length(blocks)=0 then for i=mi to length(neat) do neat[i] = ' ' end for if match_mask(neat,mask,mi,length(mask)) then if length(res)=0 then res = neat else for i=1 to length(neat) do if neat[i]!=res[i] then res[i] = '?' end if end for end if end if else integer b = blocks[1] blocks = blocks[2..$] integer l = (sum(blocks)+length(blocks)-1), e = length(neat)-l-b for i=mi to e do for j=i to i+b-1 do neat[j] = '#' end for if i+b<=length(neat) then neat[i+b] = ' ' end if if match_mask(neat,mask,mi,min(i+b,length(mask))) then res = innr(mask,blocks,i+b+1,res,neat) end if neat[i] = ' ' end for end if return resend function

function logic()integer wasunsolved = unsolved for i=1 to length(x) do grid[i] = inner(grid[i],x[i]) end for for j=1 to length(y) do string tmp = inner(vmask(grid,j),y[j]) for i=1 to length(tmp) do grid[i][j] = tmp[i] end for end for unsolved = count_grid() return wasunsolved!=unsolvedend function

module(clpfd) is written by Markus Triska
Solution written by Lars Buitinck

Module solve-nonogram.pl

/** Nonogram/paint-by-numbers solver in SWI-Prolog. Uses CLP(FD),* in particular the automaton/3 (finite-state/RE) constraint.* Copyright (c) 2011 Lars Buitinck.* Do with this code as you like, but don't remove the copyright notice.*/

#lang racket;;; --------------------------------------------------------------------------------------------------;;; Representaiton is done with bits: the bit patterns for a block being:;;; -------------------------------------------------------------------------;;; #b00 (0) - block is not in representation (also a terminator on the left);;; #b01 (1) - block is white;;; #b10 (2) - block is black;;; #b11 (3) - block is undecided;;; None of the problems has > 32 columns, so 64-bits should be fine;;; If we go above 64-bits, then a. we have a difficult problem;;; b. racket will use bignums rather;;; than fixnums;;;;;; A "blocks" is an integer formed of two-bit block codes (above);;;;;; A "representation" is a sequence (list) of black stretch lengths; which need to be separated by at;;; least one white between, and optionally prefixed and suffied with whites;;;;;; A "candidate" is a sequence (list) of <white-length [black-length white-length]...>, specifying;;; one instance of a "representation".;;;;;; A "puzzle" is a sequence (vector) of blocks;;; -- if the puzzle is <= 32 blocks wide, this could well be an fxvector (but ignore that;;; possibility for now);;;;;; "Options" is a sequence (list) of blocks;;;;;; white is often abbreviated (in variables etc. to W), black to "B";;; --------------------------------------------------------------------------------------------------(module+ test (require rackunit))(define *problems-file-name* "nonogram_problems.txt")

;; Given a (non-empty) sequence of blocks return a list of blocks which must be black, must be;; white or have to be dertermined another way (through matching along the other axis).(define (find-definite-blocks blocks) (for/fold ((known (sequence-ref blocks 0))) ((merge blocks)) (bitwise-ior known merge)))

;;; --------------------------------------------------------------------------------------------------;;; SOLVER (finally!):;;; --------------------------------------------------------------------------------------------------;;; solve the nonogram... both "solvers" return as values:;;; solution-changed? did the solution change -- if not we either have a solution or as good a;;; solution as the program can provide;;; new-solution the newly-changed solution;;; new-x-blocks x-blocks that are now available as candidates;;; new-y-blocks y-blocks that are now available as candidates(define (solved? blocks) (for/and ((b blocks)) (= (sequence-length b) 1)))