Binero puzzle solver

Question

During my holiday I decided to implement a solver for those puzzles my girlfriend likes to do. They are called Takuzu, but "binero" in Dutch.

The puzzle gives you a grid in which you have to fill in either a 1 or a 0. The constraints are the following:

1. No 3 adjacent values may be the same in a row or column
2. No two rows may be equal
3. No two columns may be equal

My first attempt to solve this was using a brute force approach. Yesterday, inspired by Peter Norvig's Sudoku solver I tried it in a more smart way.

I have a function that takes a grid, which is represented as a list of lists, and tries to fill in all the values that are 100% sure to be a 1 or a 0. This can be determined by finding all pairs of 0's or 1's.

E.g., the example below allows us to fill in a 1 at position a1 and d1 because we would otherwise create a sequence of 3 or 4 0's.

This function is then applied in a fixpoint fashion until the input is the same as the output. At which point, it seemed, that all bineros are solved. I have a test batch of 590 inputs from around the web along with their solution.

   a b c d
1. x 0 0 x
2. x x x x
3. x x x x

The solver:

#lang racket

(provide solve)


;; Defines the variable we us as empty.
(define x 'x)


;; Check if a given value is an unknown.
(define (unknown? x) 
  (equal? x 'x))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;; INDEXING ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Returns the value on the given position, false if the position is invalid.
(define (get binero coords)
  (let ((dim (length binero))
        (x (car coords))
        (y (cdr coords)))
    (if (or (> 0 x) (> 0 y) (<= dim x) (<= dim y))
        #f
        (list-ref (list-ref binero (cdr coords)) (car coords)))))

;; Updates the value at the given position (non-destructive).
;; Does not update if position is invalid.
(define (binero-set! binero coords value)
  (define (list-replace lst nth value)
    (cond
      ((null? lst) lst)
      ((eq? 0 nth) (cons value (cdr lst)))
      (else (cons (car lst) (list-replace (cdr lst) (- nth 1) value)))))
  (let ((x (car coords))
        (y (cdr coords)))
    (cond
      ((null? binero) binero)
      ((eq? 0 y)
       (cons (list-replace (car binero) (car coords) value)
             (cdr binero)))
      (else
       (cons (car binero)
             (binero-set! (cdr binero) (cons (car coords) (- (cdr coords) 1)) value))))))


;;; (0,0) is top left corner.
(define (left-of coord)
  (cons (- (car coord) 1) (cdr coord)))

(define (right-of coord)
  (cons (+ (car coord) 1) (cdr coord)))

(define (top-of coord)
  (cons (car coord) (- (cdr coord) 1)))

(define (below-of coord)
  (cons (car coord) (+ (cdr coord) 1)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;; HELPERS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Prints a binero with each row on a new line.
(define (display-binero binero)
  (if (not (or (equal? #f binero) (null? binero)))
      (begin (display (car binero))
             (newline)
             (display-binero (cdr binero)))
      '()))

(define (certain-value binero coord)
  (let* ((curr   (get binero coord))
         (left   (get binero (left-of coord)))
         (lleft  (get binero (left-of (left-of coord))))
         (right  (get binero (right-of coord)))
         (rright (get binero (right-of (right-of coord))))
         (above  (get binero (top-of coord)))
         (aabove (get binero (top-of (top-of coord))))
         (below  (get binero (below-of coord)))
         (bbelow (get binero (below-of (below-of coord)))))
    (cond
      ;; Already filled in.
      ((not (unknown? curr))
       curr)
      ;; Two left values are the same.
      ((and (eq? lleft left) (member left '(1 0)))
       (abs (- left 1)))
      ;; Two right values are the same.
      ((and (eq? rright right) (member right '(1 0)))
       (abs (- right 1)))
      ;; Two top values are the same.
      ((and (eq? above aabove) (member above '(1 0)))
       (abs (- above 1)))
      ;; Two bottom values are the same.
      ((and (eq? below bbelow) (member below '(1 0)))
       (abs (- below 1)))
      ;; Bottom and top are the same.
      ((and (eq? below above) (member below '(1 0)))
       (abs (- below 1)))
      ;; Left and right are the same.
      ((and (eq? left right) (member left '(1 0)))
       (abs (- left 1)))    
      (else curr))))

(define (solve-certainties binero)
  (let ((dim (length binero)))
    (let row-loop ((y 0)
                   (b binero))
      (if (< y dim)
          (let col-loop ((x 0)
                         (bb b))
            (if (< x dim)
                (let* ((coords (cons x y))
                       (new-value (certain-value bb coords))
                       (new-binero (binero-set! bb coords new-value)))
                  (col-loop (+ x 1) new-binero))
                (row-loop (+ y 1) bb)))
          b))))

(define (solve binero)
  (let ((pass (solve-certainties binero)))
    (if (equal? pass binero)
        pass
        (solve pass))))

Specific questions:

Do you think it would be faster to represent the grid in any other way? I had tried to make the certain-value cleaner by inputting the binero and then transposing it. This way I only had to check row-wise combinations eac time and it halves the conditional. However, this resulted in execution times of an order of magnitude higher.

Can you give me pointers on how to make this program a bit more dense yet readable? In general I would like some feedback on the quality of the code, and perhaps how I can make it faster.

Answer 1

I'll give some feedback using the Racket Style Guide as a reference.

First, I noticed your code doesn't do any input checking. I would use contracts to specify the inputs to your functions.

For example, you can write a contract like this on your exported function:

(provide (contract-out [solve (-> grid/c grid/c)]))

(define grid/c
  (listof (listof (or/c 'x 0 1))))

This specifies the input and output for the solve function have to be lists of lists containing 'x, 0, or 1. You can even specify more interesting constraints, like the column and row lengths should be the same.

The style guide suggests using internal definitions over let. Here's one way to refactor the get function:

(define (get binero coords)
  (define dim (length binero))
  (match-define (cons x y) coords)
  (if (or (> 0 x) (> 0 y) (<= dim x) (<= dim y))
      #f
      (list-ref (list-ref binero y) x))))

Note that I used the match-define form, which does a pattern match on its right-hand side expression. Using pattern matching like this can make code more terse.

On the algorithmic side, I would consider replacing your uses of lists of lists with indexed data structures since you access the lists by indexing anyway (which is usually inefficient). Racket comes with a matrix data structure. Or you could use a vector of vectors.

Also it's unusual that binero-set! does a non-destructive update despite having the ! in its name. Typically the ! is reserved for destructive or side-effecting functions. You might consider just using destructive updates after copying the original data structure. Alternatively, look into a functional data structure with efficient indexing such as a persistent vector.

You can also replace uses of manual let looping with terser looping constructs like for loops. Here's an example refactoring:

(define (solve-certainties binero)
  (define dim (length binero))
  (for/fold ([b binero]) ([y (in-range dim)])
    (for/fold ([bb b]) ([x (in-range dim)])
      (define coords (cons x y))
      (define new-value (certain-value bb coords))
      (define new-binero (binero-set! bb coords new-value))
      new-binero)
    b))

You can look up how the for/fold loop form works in the Racket docs section on looping.

Note: I haven't tested my refactorings since I didn't have any puzzle inputs on hand. If you haven't already, you may want to write unit tests for your program (e.g., using rackunit). It would be helpful for code review too!

---

BTW, you may also wish to consider using the Racket profiler and optimization coach if you want advice on how to make your program faster.