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

|#

Advertisements

1 Comment »

  1. look at these nongrams at http://crosswords-world.net/jap/
    японские кроссворды

    Comment by Jay — June 1, 2009 @ 10:34 am


RSS feed for comments on this post.

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Blog at WordPress.com.

%d bloggers like this: