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)


#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")
 
;;; --------------------------------------------------------------------------------------------------
;;; Parsing Input
;;; --------------------------------------------------------------------------------------------------
(define (letter-rep->number-rep c) (+ 1 (- (char->integer (char-upcase c)) (char->integer #\A))))
 
;; takes the letters representation, returns a list of list of numbers. The list returned is an
;; "option" - a list of ([white-width black-width] ... white-width)
(define (letters-rep->list²-rep s)
  (for/list ((b (regexp-split #rx" +" s)))
    (map letter-rep->number-rep (string->list b))))
 
(define (read-nonogram-description prt)
  (match (read-line prt)
    [(? eof-object?) #f]
    ["" (read-nonogram-description prt)]
    [(? string? l)
     (vector (letters-rep->list²-rep l)
             (letters-rep->list²-rep (read-line prt)))]))
 
(define (read-one-nonogram-from-file file-name)
  (call-with-input-file file-name read-nonogram-description))
 
(module+ test
  (check-equal? (map letter-rep->number-rep '(#\A #\a #\B #\C)) '(1 1 2 3))  
  (check-equal? (letters-rep->list²-rep "C BA CB BB F AE F A B")
                '([3] [2 1] [3 2] [2 2] [6] [1 5] [6] [1] [2]))
  (check-equal? (letters-rep->list²-rep "AB CA AE GA E C D C")
                '([1 2]  [3 1]  [1 5]  [7 1]  [5]  [3]  [4] [3]))
  (check-equal? (read-one-nonogram-from-file *problems-file-name*)
                #(([3] [2 1] [3 2] [2 2] [6] [1 5] [6] [1] [2])
                  ([1 2]  [3 1]  [1 5]  [7 1]  [5]  [3]  [4] [3]))))
 
;;; --------------------------------------------------------------------------------------------------
;;; Generate Candidates
;;; --------------------------------------------------------------------------------------------------
(define (rep->candidates n-cells blacks)
  (define (inr cells-remain bs leftmost?)
    (define bs-l (sequence-length bs))
    (define min-space-needed (- (apply + bs-l bs) 1))
    (cond
      [(null? bs) (list (list cells-remain))]
      [(> min-space-needed cells-remain) null]
      [else
       (define initial-whites-min-size (if leftmost? 0 1))
       (define intial-whites-range
         (in-range initial-whites-min-size (add1 (- cells-remain min-space-needed))))
       (for*/list ((intial-whites intial-whites-range)
                   (tl (in-list (inr (- cells-remain intial-whites (car bs)) (cdr bs) #f))))
         (list* intial-whites (car bs) tl))]))
  (inr n-cells blacks #t))
 
(module+ test
  (check-match
   (rep->candidates 5 '(1)) (list-no-order '(0 1 4) '(1 1 3) '(2 1 2) '(3 1 1) '(4 1 0)))
  (check-match
   (rep->candidates 5 '(1 1))
   (list-no-order '(0 1 1 1 2) '(0 1 2 1 1) '(0 1 3 1 0) '(1 1 1 1 1) '(1 1 2 1 0) '(2 1 1 1 0))))
 
(define (make-Ws l) (for/fold ((rv 0)) ((_ l)) (+ (* 4 rv) #b01)))
(define (make-Bs l) (* 2 (make-Ws l)))
(module+ test
  (check-eq? (make-Ws 0) #b00)
  (check-eq? (make-Bs 0) #b00)
  (check-eq? (make-Ws 1) #b01)
  (check-eq? (make-Bs 1) #b10)
  (check-eq? (make-Ws 3) #b010101)
  (check-eq? (make-Bs 3) #b101010))
 
(define (candidate->blocks cand)
  (define (inr cand rv)
    (match cand
      [(list (and W (app make-Ws Ws)) (and B (app make-Bs Bs)) r ...)
       (inr r (+ (arithmetic-shift rv (* 2 (+ B W))) (arithmetic-shift Ws (* 2 B)) Bs))]
      [(list (and W (app make-Ws Ws))) (+ (arithmetic-shift rv (* 2 W)) Ws)]))
  (inr cand 0))
 
(module+ test
  (check-eq? (candidate->blocks '(0)) 0)
  (check-eq? (candidate->blocks '(1)) #b01)
  (check-eq? (candidate->blocks '(1 1 1)) #b011001)
  (check-equal?
   (map candidate->blocks
        '((0 1 1 1 2) (0 1 2 1 1) (0 1 3 1 0) (1 1 1 1 1) (1 1 2 1 0) (2 1 1 1 0)))
   '(#b1001100101 #b1001011001 #b1001010110 #b0110011001 #b0110010110 #b0101100110)))
 
;; 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)))
 
(module+ test
  (check-eq? (find-definite-blocks '(#b010101 #b010110 #b100110)) #b110111)
  )
 
;; returns the list of blocks (from options) that can be overlaid over the solution
;; this means that the following must hold false for all bits (if it holds false, we can do a zero?
;; test, which is easiser than an all-significant-bits-set? test:
;; pattern cand  
;;    0      0     F
;;    0      1     T
;;    1      0     F
;;    1      1     F
;; (cand !bitwise-impl pattern) = !(pattern | !cand) = (!pattern & cand)
(define (filter-against-partial-solution part-sltn options)
  (define not-part-sltn (bitwise-not part-sltn))
  (define (option-fits? cand) (zero? (bitwise-and cand not-part-sltn)))
  (filter option-fits? options))
 
(module+ test
  (check-equal?
   (filter-against-partial-solution #b011110 '(#b101010 #b010110 #b011010))
   '(#b010110 #b011010)))
 
;;; --------------------------------------------------------------------------------------------------
;;; Rendering -- it's pretty tough to see what's going on, when you have no pictures!
;;; --------------------------------------------------------------------------------------------------
(define ((render-puzzle knil kons-W kons-B kons-_ compose-lines) pzl)
  (define (render-blocks bs)
    (define (inr bs acc)
      (match (bitwise-and bs #b11)
        [#b00 acc]
        [#b01 (inr (arithmetic-shift bs -2) (kons-W acc))]
        [#b10 (inr (arithmetic-shift bs -2) (kons-B acc))]
        [#b11 (inr (arithmetic-shift bs -2) (kons-_ acc))]))
    (inr bs knil))
  (compose-lines (map render-blocks pzl)))
 
(define string-render-puzzle
  (render-puzzle ""
                 (curry string-append ".")
                 (curry string-append "#")
                 (curry string-append "?")
                 (curryr string-join "\n")))
 
(module+ test
  (check-equal? (string-render-puzzle '(#b101010 #b010101 #b111111)) "###\n...\n???"))
 
;;; We need to work on x and y blocks uniformly, so this will convert from one to t'other
;;; Rotates a sequence of blocks
(define (rotate-blocks x-blocks)
  (define x-width- (integer-length (sequence-ref x-blocks 0)))
  (define x-width (if (odd? x-width-) (add1 x-width-) x-width-))
  ;(printf "~a ~a" x-width x-blocks)
  (for/list ((block-idx (in-range x-width 0 -2)))
    (for/fold ((y-block 0))
      ((x-block x-blocks))
      (+ (arithmetic-shift y-block 2)
         (bitwise-bit-field x-block (- block-idx 2) block-idx)))))
 
(module+ test
  (check-equal? (rotate-blocks '(#b1110 #b0111)) '(#b1101 #b1011))
  (check-equal? (rotate-blocks '(#b0110 #b0111)) '(#b0101 #b1011)))
 
;;; --------------------------------------------------------------------------------------------------
;;; 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)))
 
(define (solve-nonogram x-rep.y-rep) ; pair of reps as read from e.g. read-nonogram-from-file
  (match-define (vector x-rep y-rep) x-rep.y-rep)
  (define width (sequence-length y-rep))
  (define height  (sequence-length x-rep))
  (define x-candidates (map (curry rep->candidates width) x-rep))
  (define y-candidates (map (curry rep->candidates height) y-rep))
  (define x-options    (for/list ((cnds x-candidates)) (map candidate->blocks cnds)))
  (define y-options    (for/list ((cnds y-candidates)) (map candidate->blocks cnds)))
 
  (define-values (solution complete?) (sub-solve-nonogram x-options y-options))
  (unless complete? (displayln "INCOMPLETE SOLUTION"))
  solution)
 
(define (sub-solve-nonogram x-options y-options)
  (define known-x (map find-definite-blocks x-options))
  (define known-y (map find-definite-blocks y-options))
  (cond
    [(solved? x-options) (values known-x #t)]
    [else
     (define new-y-options (map filter-against-partial-solution (rotate-blocks known-x) y-options))
     (define new-x-options (map filter-against-partial-solution (rotate-blocks known-y) x-options))
     (displayln (string-render-puzzle (map find-definite-blocks new-x-options)) (current-error-port))
     (newline (current-error-port))     
     (if (and (equal? x-options new-x-options) (equal? y-options new-y-options))
         (values known-x #f) ; oh... we can't get any further
         (sub-solve-nonogram new-x-options new-y-options))]))
 
;;;; TESTING
(module+ test
  (define chicken #<<EOS
.###....
##.#....
.###..##
..##..##
..######
#.#####.
######..
....#...
...##...
EOS
    )
  (check-equal?
   (string-render-puzzle (solve-nonogram (read-one-nonogram-from-file *problems-file-name*)))
   chicken))
 
;;; IMAGE RENDERING
(require pict racket/gui/base)
 
(define *cell-size* 10)
(define ((paint-cell fill-colour) dc dx dy)
  (define C (- *cell-size* 1))
  (define old-brush (send dc get-brush))
  (define old-pen (send dc get-pen))        
  (define path (new dc-path%))
  (send path rectangle 0 0 C C)
  (send* dc
    (set-brush (new brush% [color fill-colour]))
    (set-pen (new pen% [width 1] [color "black"]))
    (draw-path path dx dy)
    (set-brush old-brush)
    (set-pen old-pen)))
 
(define (draw-cell fill-colour)
  (dc (paint-cell fill-colour)
      *cell-size* *cell-size*))
 
(define ((row-append-cell colour) row-so-far)
  (hc-append (draw-cell colour)  row-so-far))
 
(define image-render-puzzle
  (render-puzzle
   (blank)
   (row-append-cell "white")
   (row-append-cell "black")
   (row-append-cell "yellow")
   (λ (rows) (apply vc-append rows))))
 
(module+ test
  ; test though visual inspection... it's a style thing, really
  (image-render-puzzle (solve-nonogram (read-one-nonogram-from-file *problems-file-name*))))
 
;;; MAIN
(module+ main
  (unless (directory-exists? "images") (make-directory "images"))
 
  (call-with-input-file *problems-file-name*
    (lambda (prt)
      (let loop ((idx 1) (pzl (read-nonogram-description prt)) (collage (blank)))
        (cond
          [pzl
           (define img (image-render-puzzle (solve-nonogram pzl)))
           (send (pict->bitmap img) save-file (build-path "images" (format "nonogram-~a.png" idx))
                 'png)
           (displayln (image-render-puzzle (solve-nonogram pzl)))
           (loop (add1 idx) (read-nonogram-description prt) (vl-append 2 collage img))]
          [else
           (send (pict->bitmap collage) save-file (build-path "images" (format "nonogram-all.png"))
                 'png)
           (displayln collage)])))))