I 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.
#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))))
#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))))
