# Rcjp's Weblog

## October 11, 2006

### Nonograms in Common Lisp

Filed under: lisp — rcjp @ 1:47 pm

``` ;;; ;;; Nonograms are puzzles from Sunday Telegraph: the length and order ;;; of blocks in a grid are given along both rows and columns the ;;; challenge is to work out how many spaces occur between the blocks ;;; and find the hidden picture (see example below) ;;; ;;; the strategy we use is to generate all the possible spacings ;;; of blocks and see if any parts of the grid, for all possible ;;; solutions, are always filled '1' or always empty '0' (defun common-bits (bitvecs) "Returns a bit vector with '1' in positions where all supplied bitvectors all have 1 or 0" (let ((firstvec (first bitvecs))) (reduce #'bit-and (loop for bv in bitvecs collect (bit-eqv firstvec bv))))) (defun common-list-positions (lists) "Returns a list of (value . position) elements common to all lists" (let ((bitvecs (mapcar #'(lambda (list) (coerce list 'bit-vector)) lists))) (loop with common = (common-bits bitvecs) with vec = (first bitvecs) for start = 0 then (1+ pos) for pos = (position 1 common :start start) while pos collect (cons (sbit vec pos) pos)))) (defun make-section (lhs lspace blocksize rhs &optional not-end-section) "Make a section of a row (also used for columns), the end piece has the rhs full of spaces else just pad a space ready for the next section" (append lhs (make-list lspace :initial-element 0) (make-list blocksize :initial-element 1) (if not-end-section '(0) (make-list rhs :initial-element 0)))) (defun blocks-spacings (blocklist nspaces &optional prevblocks) "Calculate all the arrangements of the list of blocks over nspaces" (loop with blocklen = (first blocklist) with moreblocks = (rest blocklist) with maxleft = (- nspaces (+ (apply #'+ moreblocks) (length moreblocks))) ;; ;; working left-to-right, work out all possible positions for the ;; current block recursively calling for blocks to the rhs ;; for blockpos upto (- maxleft blocklen) for section = (make-section prevblocks blockpos blocklen (- maxleft blocklen blockpos) moreblocks) ;; ;; build the row (column) in sections, appending sections to the ;; collect'ed right hand edge sections ;; when moreblocks append (blocks-spacings moreblocks (- nspaces blockpos blocklen 1) section) else collect section)) (defun find-spacings (blocklists nspaces) "Generate a vector from the blocklists where each element holds all possible arrangements of each blocklist in nspaces" (let ((board (make-array (length blocklists) :fill-pointer 0))) (dolist (blocklist blocklists board) (vector-push (blocks-spacings blocklist nspaces) board)))) (defun multiple-solutions-p (boardx boardy) "If there is more than one possible arrangement anywhere - its not solved" (flet ((length1-p (seq) (= (length seq) 1))) (or (notevery #'length1-p boardx) (notevery #'length1-p boardy)))) (defun print-board (board) (loop for row across board do (format t "~{~&~{~[ ~;o~]~}~}" row))) (defun delete-arrangement (array element test) "Delete from the list of arrangements in array element those that fail the test" (setf (aref array element) (delete-if-not test (aref array element)))) (defun eltcheck (index val) "Returns a function which can be applied to a sequence to check if the index value is val" #'(lambda (n) (= (elt n index) val))) (defun nonogram (row-blocks col-blocks &optional (maxiterations 100)) "Solve the nongram described by the list of row-blocks and col-blocks, give up after maxiterations" (let ((possible-rows (find-spacings row-blocks (length col-blocks))) (possible-cols (find-spacings col-blocks (length row-blocks)))) (flet ((find-apply-rules (board-find board-apply) (dotimes (line (length board-find)) (dolist (rule (common-list-positions (aref board-find line))) (delete-arrangement board-apply (cdr rule) (eltcheck line (car rule))))))) (loop while (multiple-solutions-p possible-rows possible-cols) repeat maxiterations do (find-apply-rules possible-rows possible-cols) (find-apply-rules possible-cols possible-rows)) (print-board possible-rows)))) #| e.g. (nonogram '((5) (4) (3 3 3) (8 1) (7 3 3) (2 2 5 1) (1 6 3 1) (3 3 2) (3 2 1) (2 2) (1 2) (1 2) (2) (2) (2) (2) (8) (11) (13) (4 4 5 3) (3 2 3 3) (2 3) (20) (14 1 2) (4 1 12)) '((6) (6) (2 3) (3 1 3) (3 1 2) (3 5 3 2) (3 4 4 3) (7 5 2) (4 4 3) (4 2 3 3) (4 14 3) (20 3) (2 2 5 3) (1 3 5 3) (1 3 5 1 1) (1 3 3 1 1) (1 1 3) (3 4 1) (1 6) (3 6))) => ooooo oooo ooo ooo ooo oooooooo o ooooooo ooo ooo oo oo ooooo o o oooooo ooo o ooo ooo oo ooo oo o oo oo o oo o oo oo oo oo oo oooooooo ooooooooooo ooooooooooooo oooo oooo ooooo ooo ooo oo ooo ooo oo ooo oooooooooooooooooooo oooooooooooooo o oo oooo o oooooooooooo |# ```