716 lines
30 KiB
Racket
716 lines
30 KiB
Racket
|
|
|
|
(module solve mzscheme
|
|
|
|
(require mzlib/list
|
|
mzlib/etc
|
|
mzlib/contract)
|
|
|
|
(provide/contract [solve (-> (listof (listof integer?)) ; row-info
|
|
(listof (listof integer?)) ; col-info
|
|
(-> number? number? symbol? ; set-entry
|
|
void?)
|
|
(-> number? void?) ; setup-progress
|
|
void)])
|
|
|
|
(define (solve row-info col-info set-entry setup-progress)
|
|
(local (
|
|
(define (pause) '(sleep 1/16))
|
|
|
|
; all test cases are commented out.
|
|
|
|
; to work on large lists, we must make filter tail-recursive.
|
|
; this one reverses.
|
|
|
|
; filter-rev : returns a list of all elements in a-list which
|
|
; satisfy the predicate. If a precedes b in a-list, and both
|
|
; occur in the result, then b will precede a in the result.
|
|
; ((A -> boolean) (list-of A) -> (list-of A))
|
|
|
|
(define (filter-rev fun a-list)
|
|
(foldl (lambda (elt built-list)
|
|
(if (fun elt)
|
|
(cons elt built-list)
|
|
built-list))
|
|
null
|
|
a-list))
|
|
|
|
;(equal? (filter-rev (lambda (x) (> x 13)) '(2 98 27 1 23 2 09))
|
|
; '(23 27 98))
|
|
|
|
|
|
; transpose : transposes a matrix represented as a list of lists
|
|
; ((list-of (list-of T)) -> (list-of (list-of T)))
|
|
|
|
(define (transpose list-list)
|
|
(apply map list list-list))
|
|
|
|
;(equal? (transpose '((a b c d e)
|
|
; (f g h i j)
|
|
; (k l m n o)))
|
|
; '((a f k)
|
|
; (b g l)
|
|
; (c h m)
|
|
; (d i n)
|
|
; (e j o)))
|
|
|
|
|
|
; TYPE-DECLARATIONS:
|
|
; there are three kinds of cell-list: the board-row-list, the tally-list, and the try-list.
|
|
;
|
|
; (type: board-row (list-of (union 'off 'on 'unknown)))
|
|
; (type: tally-row (list-of (union 'off 'on 'unknown 'maybe-off 'maybe-on 'mixed)))
|
|
; (type: try-row (list-of (union 'maybe-off 'maybe-on 'unknown)))
|
|
(define try-row? (listof (symbols 'maybe-off 'maybe-on 'unknown)))
|
|
(define try-batch? (listof (or/c number? (listof try-row?))))
|
|
|
|
;
|
|
; (type: board (list-of board-row))
|
|
|
|
; board-ref : returns the board element in (col,row);
|
|
; (board num num -> (union 'on 'off 'unknown))
|
|
|
|
(define (board-ref board row col)
|
|
(list-ref (list-ref board row) col))
|
|
|
|
; board-width : returns the width of the board
|
|
; (board -> num)
|
|
|
|
(define (board-width board)
|
|
(length (car board)))
|
|
|
|
; board-height : returns the height of the board
|
|
; (board -> num)
|
|
|
|
(define (board-height board)
|
|
(length board))
|
|
|
|
; extract-rows : returns the board as a list of rows
|
|
; (board -> board)
|
|
|
|
(define (extract-rows board)
|
|
board)
|
|
|
|
; extract-cols : returns the board as a list of columns
|
|
; (board -> board)
|
|
|
|
(define (extract-cols board)
|
|
(transpose board))
|
|
|
|
; reassemble-rows : turns a list of rows into a board
|
|
; (board -> board)
|
|
|
|
(define (reassemble-rows board-line-list)
|
|
board-line-list)
|
|
|
|
; reassemble-cols : turns a list of columns into a board
|
|
; (board -> board)
|
|
|
|
(define (reassemble-cols board-line-list)
|
|
(transpose board-line-list))
|
|
|
|
; entirely-unknown : does this row consist entirely of 'unknown?
|
|
|
|
(define (entirely-unknown row)
|
|
(andmap (lambda (x) (eq? x 'unknown)) row))
|
|
|
|
; finished? : does this board contain no unknown squares?
|
|
|
|
(define (finished? board)
|
|
(not (ormap (lambda (row) (ormap (lambda (cell) (eq? cell 'unknown)) row)) board)))
|
|
|
|
|
|
; threshold info : the threshold is the limit at which
|
|
; memoize-tries will simply give up.
|
|
|
|
(define initial-threshold 2000)
|
|
|
|
(define (next-threshold threshold)
|
|
(+ threshold 2000))
|
|
|
|
|
|
; procedures to simplify the construction of test cases:
|
|
|
|
; condensed->long-form : takes a tree of short-form symbols and
|
|
; converts them to their long form, following this mapping:
|
|
; u -> unknown | X -> off
|
|
; ? -> maybe-on | O -> on
|
|
; ! -> maybe-off | * -> mixed
|
|
|
|
(define (condensed->long-form symbol-tree)
|
|
(cond [(cons? symbol-tree)
|
|
(cons (condensed->long-form (car symbol-tree))
|
|
(condensed->long-form (cdr symbol-tree)))]
|
|
[(case symbol-tree
|
|
((u) 'unknown)
|
|
((?) 'maybe-on)
|
|
((!) 'maybe-off)
|
|
((X) 'off)
|
|
((O) 'on)
|
|
((*) 'mixed)
|
|
((()) ())
|
|
(else (error 'condensed->long-form "bad input: ~a" symbol-tree)))]))
|
|
|
|
;(equal? (condensed->long-form '(((? !) u) (* () X O)))
|
|
; '(((maybe-on maybe-off) unknown) (mixed () off on)))
|
|
|
|
; check-changed : check whether a tally-row reveals new information to be added
|
|
; to the grid
|
|
; (tally-row -> boolean)
|
|
|
|
(define (check-changed tally-list)
|
|
(ormap (lambda (cell)
|
|
(case cell
|
|
((off on unknown mixed) #f)
|
|
((maybe-off maybe-on) #t)
|
|
(else (error "unknown element found in check-changed: ~a" cell))))
|
|
tally-list))
|
|
|
|
;(and (equal? (check-changed '(off off on unknown mixed)) #f)
|
|
; (equal? (check-changed '(off on maybe-off on mixed)) #t)
|
|
; (equal? (check-changed '(off maybe-on on on unknown)) #t))
|
|
|
|
; rectify : transform a tally-row into a board row, by changing maybe-off
|
|
; to off and maybe-on to on.
|
|
; (tally-row -> board-row)
|
|
|
|
(define (rectify tally-list)
|
|
(map (lambda (cell)
|
|
(case cell
|
|
((off on unknown) cell)
|
|
((maybe-off) 'off)
|
|
((maybe-on) 'on)
|
|
((mixed) 'unknown)
|
|
(else (error "unknown element in rectified row"))))
|
|
tally-list))
|
|
|
|
;(equal? (rectify '(off on maybe-on mixed unknown maybe-off))
|
|
; '(off on on unknown unknown off))
|
|
|
|
; make-row-formulator:
|
|
; given a set of block lengths, create a function which accepts a
|
|
; set of pads and formulates a try-row:
|
|
; (num-list -> (num-list num -> (list-of (union 'maybe-off 'maybe-on 'unknown))))
|
|
|
|
(define (make-row-formulator blocks)
|
|
(lambda (pads)
|
|
(apply append
|
|
(let loop ([pads pads]
|
|
[blocks blocks])
|
|
(cond [(null? (cdr pads))
|
|
(if (null? blocks)
|
|
(list (build-list (car pads) (lambda (x) 'maybe-off)))
|
|
(list (cons 'maybe-off (build-list (apply + -1 (car pads) blocks) (lambda (x) 'unknown)))))]
|
|
[else
|
|
(cons (build-list (car pads) (lambda (x) 'maybe-off))
|
|
(cons (build-list (car blocks) (lambda (x) 'maybe-on))
|
|
(loop (cdr pads) (cdr blocks))))])))))
|
|
|
|
#|
|
|
(equal? ((make-row-formulator '(3 1 1 5)) '(1 2 1 3 3))
|
|
'(maybe-off maybe-on maybe-on maybe-on maybe-off maybe-off maybe-on maybe-off maybe-on
|
|
maybe-off maybe-off maybe-off maybe-on maybe-on maybe-on maybe-on maybe-on
|
|
maybe-off maybe-off maybe-off))
|
|
|
|
(equal? ((make-row-formulator '(3 1 1 5)) '(2 4 4))
|
|
'(maybe-off maybe-off
|
|
maybe-on maybe-on maybe-on
|
|
maybe-off maybe-off maybe-off maybe-off
|
|
maybe-on
|
|
unknown unknown unknown unknown unknown unknown unknown unknown unknown unknown))
|
|
|#
|
|
|
|
#| check-try :
|
|
see whether a try fits with the existing row information (curried)
|
|
(tally-row -> (try-row -> boolean))
|
|
|#
|
|
|
|
(define (check-try tally-list)
|
|
(lambda (try-list)
|
|
(andmap (lambda (tally try)
|
|
(or (eq? try 'unknown)
|
|
(case tally
|
|
((off) (eq? try 'maybe-off))
|
|
((on) (eq? try 'maybe-on))
|
|
(else #t))))
|
|
tally-list
|
|
try-list)))
|
|
|
|
#|
|
|
(equal? ((check-try '(unknown off on unknown unknown unknown))
|
|
'(maybe-on maybe-on maybe-on maybe-off maybe-off maybe-off))
|
|
#f)
|
|
|
|
(equal? ((check-try '(unknown off on unknown unknown unknown))
|
|
'(maybe-off maybe-off maybe-on maybe-on maybe-on maybe-off))
|
|
#t)
|
|
|
|
(equal? ((check-try '(unknown off on unknown unknown unknown))
|
|
'(unknown unknown unknown unknown unknown unknown))
|
|
#t)
|
|
|#
|
|
|
|
#| choose : like math. as in, "9 choose 3"
|
|
(num num -> num)
|
|
|#
|
|
|
|
(define (factorial a)
|
|
(if (<= a 1)
|
|
1
|
|
(* a (factorial (- a 1)))))
|
|
|
|
(define (choose a b)
|
|
(if (> b a)
|
|
(error 'choose "(choose ~v ~v): ~v is greater than ~v" a b b a)
|
|
(let ([b (max b (- a b))])
|
|
(/ (let loop ([x a])
|
|
(if (= x (- a b))
|
|
1
|
|
(* x (loop (- x 1)))))
|
|
(factorial b)))))
|
|
|
|
#|
|
|
(and
|
|
(= (choose 0 0) 1)
|
|
(= (choose 10 10) 1)
|
|
(= (choose 10 1) 10)
|
|
(= (choose 10 2) 45)
|
|
(= (choose 10 8) 45))
|
|
|#
|
|
|
|
#| initial-num-possibilities :
|
|
given a list of block lengths, calculate the number of ways they could fit
|
|
into a row of the given length. The easiest way to model this is to imagine
|
|
inserting blocks at given locations in a fixed set of spaces
|
|
|
|
(listof num) num -> num
|
|
|
|
|#
|
|
|
|
(define (initial-num-possibilities blocks size)
|
|
(choose (+ 1 (- size (apply + blocks))) (length blocks)))
|
|
|
|
#|
|
|
(= (initial-num-possibilities '(2 3 3 4) 40)
|
|
(choose 29 4))
|
|
|#
|
|
|
|
#| build-possibles:
|
|
builds a list of the possible rows. given a number of spaces, and a number
|
|
of bins to put the spaces in, and a row-formulator, and a line-checker predicate,
|
|
build-possibles makes a list of every possible row which passes the predicate.
|
|
If the number of possibilities grows larger than the threshold, the search is
|
|
aborted.
|
|
|
|
(num num ((list-of num) -> try-row) (try-row -> bool) num -> (union (list-of try-row) #f))
|
|
|#
|
|
|
|
(define (build-possibles things total-bins row-formulator line-checker threshold)
|
|
(let/ec escape
|
|
(let* ([built-list null]
|
|
[list-length 0]
|
|
[add-to-built-list
|
|
(lambda (new)
|
|
(if (= list-length threshold)
|
|
(escape #f)
|
|
(begin (set! built-list (cons new built-list))
|
|
(set! list-length (+ list-length 1)))))])
|
|
(let tree-traverse ([things things]
|
|
[bins total-bins]
|
|
[so-far-rev null])
|
|
(let* ([this-try-rev (cons things so-far-rev)]
|
|
[formulated (row-formulator (reverse this-try-rev))])
|
|
;(when (= debug-counter 0)
|
|
; (printf "~v\n~v\n" formulated (line-checker formulated)))
|
|
(when (or (= bins total-bins) (line-checker formulated))
|
|
(if (= bins 1)
|
|
(add-to-built-list formulated)
|
|
(let try-loop ([in-this-bin (if (= bins total-bins)
|
|
0
|
|
1)])
|
|
(unless (> (+ in-this-bin (- bins 2)) things)
|
|
(tree-traverse (- things in-this-bin)
|
|
(- bins 1)
|
|
(cons in-this-bin so-far-rev))
|
|
(try-loop (+ in-this-bin 1))))))))
|
|
built-list)))
|
|
|
|
|
|
#|
|
|
;build-possibles test case
|
|
(let* ([row-formulator-one (make-row-formulator '(2))]
|
|
[line-checker (check-try '(unknown unknown unknown on unknown unknown))]
|
|
[test-one (build-possibles 4 2 row-formulator-one line-checker 10000)]
|
|
[row-formulator-two (make-row-formulator '(1 1))]
|
|
[test-two (build-possibles 4 3 row-formulator-two line-checker 10000)])
|
|
(and
|
|
(equal? test-one
|
|
'((maybe-off maybe-off maybe-off maybe-on maybe-on maybe-off)
|
|
(maybe-off maybe-off maybe-on maybe-on maybe-off maybe-off)))
|
|
(equal? test-two
|
|
'((maybe-off maybe-off maybe-off maybe-on maybe-off maybe-on)
|
|
(maybe-off maybe-on maybe-off maybe-on maybe-off maybe-off)
|
|
(maybe-on maybe-off maybe-off maybe-on maybe-off maybe-off)))))
|
|
|#
|
|
|
|
#| spare-spaces:
|
|
calculates the number of spare spaces in a line. In other words,
|
|
line-length - sum-of-all-blocks
|
|
|
|
((list-of num) num -> num)
|
|
|#
|
|
|
|
(define (spare-spaces block-list line-length)
|
|
(let* ([black-spaces (apply + block-list)]
|
|
[spare-spaces (- line-length black-spaces)])
|
|
spare-spaces))
|
|
|
|
; first-pass:
|
|
; generates the information about row contents which can be inferred directly
|
|
; from the block info and nothing else (i.e., uses no information from an existing
|
|
; board.
|
|
; ((list-of (list-of num)) num -> (list-of (list-of (union 'on 'unknown))))
|
|
|
|
(define (first-pass info-list line-length)
|
|
(let ((row-pass
|
|
(lambda (block-list)
|
|
(let* ([spares (- (spare-spaces block-list line-length) (max 0 (- (length block-list) 1)))]
|
|
[shortened-blocks
|
|
(map (lambda (block-length) (- block-length spares))
|
|
block-list)]
|
|
[all-but-start
|
|
(foldr append null
|
|
(let build-row-loop ([blocks-left shortened-blocks])
|
|
(if (null? blocks-left)
|
|
null
|
|
(let ([extra-pad (if (null? (cdr blocks-left)) 0 1)])
|
|
(if (> (car blocks-left) 0)
|
|
(cons (build-list (car blocks-left) (lambda (x) 'on))
|
|
(cons (build-list (+ spares extra-pad) (lambda (x) 'unknown))
|
|
(build-row-loop (cdr blocks-left))))
|
|
(cons (build-list (+ spares extra-pad (car blocks-left))
|
|
(lambda (x) 'unknown))
|
|
(build-row-loop (cdr blocks-left))))))))]
|
|
[whole-row (append (build-list spares (lambda (x) 'unknown))
|
|
all-but-start)])
|
|
whole-row))))
|
|
(map row-pass info-list)))
|
|
|
|
#|
|
|
(let ([test-result (first-pass '((4 3) (5 1)) 10)])
|
|
(equal? test-result '((unknown unknown on on unknown unknown unknown on unknown unknown)
|
|
(unknown unknown unknown on on unknown unknown unknown unknown unknown))))
|
|
|#
|
|
|
|
#| unify-passes:
|
|
unify the result of running first-pass on both the rows and the columns
|
|
(let ([BOARD (list-of (list-of (union 'unknown 'on)))])
|
|
(BOARD BOARD -> BOARD))
|
|
|#
|
|
|
|
(define (unify-passes board-a board-b)
|
|
(let ([unify-rows
|
|
(lambda (row-a row-b)
|
|
(map (lambda (cell-a cell-b)
|
|
(case cell-a
|
|
((on) 'on)
|
|
(else cell-b)))
|
|
row-a row-b))])
|
|
(map unify-rows board-a board-b)))
|
|
|
|
#|
|
|
(let* ([board-a '((unknown unknown on) (on unknown unknown))]
|
|
[board-b '((unknown on unknown) (on on unknown))]
|
|
[test-result (unify-passes board-a board-b)])
|
|
(equal? test-result '((unknown on on) (on on unknown))))
|
|
|#
|
|
|
|
#| whole-first-pass:
|
|
take a set of row descriptions and the board dimensions and generate the
|
|
merged first-pass info
|
|
((list-of (list-of num)) (list-of (list-of num)) num num ->
|
|
(list-of board-row))
|
|
|#
|
|
|
|
(define (whole-first-pass row-info col-info width height)
|
|
(unify-passes (first-pass row-info width)
|
|
(transpose (first-pass col-info height))))
|
|
|
|
#| memoize-tries:
|
|
given the black block widths and the line length and some initial board
|
|
and a progress-bar updater, calculate all possibilities for each row.
|
|
If skip-unknowns is #t, rows whose content is entirely unknown will be
|
|
skipped, and #f returned for that row.
|
|
effect: updates the progress bar
|
|
((list-of (list-of num)) num (list-of board-row) (-> void) boolean -> (union (list-of try-row) #f))
|
|
|#
|
|
|
|
(define (memoize-tries info-list line-length board-rows old-tries threshold)
|
|
(let* ([unmemoized (filter number? old-tries)])
|
|
(if (null? unmemoized)
|
|
old-tries
|
|
(let* ([least-difficult
|
|
(apply min unmemoized)])
|
|
;(fprintf (current-error-port) "guessed tries: ~v\n" least-difficult)
|
|
(map (lambda (old-try-set block-list board-row)
|
|
(cond [(and (number? old-try-set) (= old-try-set least-difficult))
|
|
(let ([spaces (spare-spaces block-list line-length)]
|
|
[bins (+ (length block-list) 1)]
|
|
[row-formulator (make-row-formulator block-list)]
|
|
[line-checker (check-try board-row)])
|
|
(or (build-possibles spaces bins row-formulator line-checker threshold)
|
|
(* 2 old-try-set)))]
|
|
[else old-try-set]))
|
|
old-tries
|
|
info-list
|
|
board-rows)))))
|
|
|
|
#|
|
|
(equal? (memoize-tries '((4) (1 3))
|
|
6
|
|
'((unknown on unknown unknown unknown unknown)
|
|
(unknown off unknown unknown unknown unknown))
|
|
void)
|
|
'(((maybe-on maybe-on maybe-on maybe-on maybe-off maybe-off)
|
|
(maybe-off maybe-on maybe-on maybe-on maybe-on maybe-off))
|
|
((maybe-on maybe-off maybe-on maybe-on maybe-on maybe-off)
|
|
(maybe-on maybe-off maybe-off maybe-on maybe-on maybe-on))))
|
|
|#
|
|
|
|
#| batch-try:
|
|
take a board-line list and a list of possibles, and trim it down by
|
|
checking each try-list against the appropriate board-line
|
|
|
|
((list-of board-row) (list-of (union (list-of try-row) #f)) -> (list-of (union (list-of try-row) #f)))
|
|
|#
|
|
|
|
(define (batch-try board-line-list try-list-list-list)
|
|
(map (lambda (line try-list-list)
|
|
(if (not (number? try-list-list))
|
|
(filter ; filter-rev
|
|
(let ([f (check-try line)])
|
|
(lambda (try-list) (f try-list)))
|
|
try-list-list)
|
|
try-list-list))
|
|
board-line-list
|
|
try-list-list-list))
|
|
|
|
#|
|
|
(equal? (batch-try '((unknown unknown unknown off)
|
|
(unknown on unknown unknown))
|
|
'(((maybe-on maybe-on maybe-on maybe-off)
|
|
(maybe-off maybe-on maybe-on maybe-on))
|
|
((maybe-on maybe-on maybe-off maybe-off)
|
|
(maybe-off maybe-on maybe-on maybe-off)
|
|
(maybe-off maybe-off maybe-on maybe-on))))
|
|
'(((maybe-on maybe-on maybe-on maybe-off))
|
|
((maybe-off maybe-on maybe-on maybe-off)
|
|
(maybe-on maybe-on maybe-off maybe-off))))
|
|
|#
|
|
|
|
; tabulate-try : take one possibility, and merge it with the row possibles
|
|
; (tally-list try-list) -> tally-list
|
|
|
|
(define (tabulate-try tally-list try-list)
|
|
(map (lambda (tally try)
|
|
(case tally
|
|
((off on mixed) tally)
|
|
((unknown) try)
|
|
((maybe-off maybe-on) (if (eq? try tally)
|
|
try
|
|
'mixed))
|
|
(else (error "unknown cell type during tabulate-try: ~a" tally))))
|
|
tally-list
|
|
try-list))
|
|
|
|
|
|
#|
|
|
(equal? (tabulate-try '(on off maybe-off maybe-off maybe-on maybe-on maybe-on)
|
|
'(on off mixed maybe-on maybe-on mixed maybe-off))
|
|
'(on off mixed mixed maybe-on mixed mixed))
|
|
|#
|
|
|
|
; batch-tabulate : take a board-line-list and a list of sets of tries which check with the board
|
|
; and tabulate them all to produce a new board line list (before rectification)
|
|
; (board-line-list try-list-list-opt-list) -> tally-list
|
|
(define (batch-tabulate board-line-list try-list-list-opt-list)
|
|
(map (lambda (board-line try-list-list-opt)
|
|
(if (not (number? try-list-list-opt))
|
|
(foldl (lambda (x y) (tabulate-try y x)) board-line try-list-list-opt)
|
|
board-line))
|
|
board-line-list
|
|
try-list-list-opt-list))
|
|
|
|
|
|
; (equal? (batch-tabulate '((unknown unknown unknown off)
|
|
; (unknown unknown on unknown))
|
|
; '(((maybe-on maybe-on maybe-off maybe-off)
|
|
; (maybe-off maybe-on maybe-on maybe-off))
|
|
; ((maybe-off maybe-on maybe-on maybe-off)
|
|
; (maybe-off maybe-off maybe-on maybe-on))))
|
|
; '((mixed maybe-on mixed off)
|
|
; (maybe-off mixed on mixed)))
|
|
|
|
(define (print-board board)
|
|
(for-each (lambda (row)
|
|
(for-each (lambda (cell)
|
|
(printf (case cell
|
|
((off) " ")
|
|
((unknown) ".")
|
|
((on) "#"))))
|
|
row)
|
|
(printf "~n"))
|
|
(extract-rows board)))
|
|
|
|
; animate-changes takes a board and draws it on the main screen
|
|
(define (animate-changes board draw-thunk outer-size inner-size)
|
|
(let outer-loop ([outer-index 0])
|
|
(if (= outer-index outer-size)
|
|
null
|
|
(let inner-loop ([inner-index 0])
|
|
(if (= inner-index inner-size)
|
|
(begin
|
|
(pause)
|
|
(outer-loop (+ outer-index 1)))
|
|
(begin
|
|
(draw-thunk board outer-index inner-index)
|
|
(inner-loop (+ inner-index 1))))))))
|
|
|
|
(define (draw-rows-thunk board row col)
|
|
(set-entry col row (board-ref board row col)))
|
|
|
|
(define (draw-cols-thunk board col row)
|
|
(set-entry col row (board-ref board row col)))
|
|
|
|
; (print-board '((on on unknown off)
|
|
; (on on unknown unknown)
|
|
; (unknown unknown on on)
|
|
; (off unknown on on)))
|
|
|
|
; do-lines takes a board-line-list and a try-list-list-list and returns two things: a tally-list-list
|
|
; and a new try-list-list-list
|
|
; (board-line-list try-list-list-opt-list) -> (tally-list-list try-list-list-opt-list)
|
|
(define do-lines
|
|
(contract
|
|
(->* (any/c try-batch?)
|
|
((listof (listof any/c)) try-batch?))
|
|
(lambda (board-line-list try-list-list-opt-list)
|
|
(let ([new-tries (batch-try board-line-list try-list-list-opt-list)])
|
|
(values (batch-tabulate board-line-list new-tries)
|
|
new-tries)))
|
|
'do-lines
|
|
'caller))
|
|
|
|
; full-set takes a board and a pair of try-list-list-lists and returns a new board, a new pair
|
|
; of try-list-list-lists, and a boolean (whether it's changed)
|
|
(define full-set
|
|
(contract
|
|
(->* (any/c try-batch? try-batch?)
|
|
(any/c try-batch? try-batch? boolean?))
|
|
(lambda (board row-try-list-list-opt-list col-try-list-list-opt-list)
|
|
(let*-values ([(board-rows new-row-tries)
|
|
(do-lines (extract-rows board) row-try-list-list-opt-list)]
|
|
[(row-changed)
|
|
(ormap check-changed board-rows)]
|
|
[(new-board)
|
|
(reassemble-rows (map rectify board-rows))]
|
|
[( _ )
|
|
(if row-changed
|
|
(animate-changes new-board draw-rows-thunk
|
|
(board-height new-board)
|
|
(board-width new-board)))]
|
|
[(board-cols new-col-tries)
|
|
(do-lines (extract-cols new-board) col-try-list-list-opt-list)]
|
|
[(col-changed)
|
|
(ormap check-changed board-cols)]
|
|
[(final-board)
|
|
(reassemble-cols (map rectify board-cols))]
|
|
[( _ )
|
|
(if col-changed
|
|
(animate-changes final-board draw-cols-thunk
|
|
(board-width final-board)
|
|
(board-height final-board)))])
|
|
(values final-board new-row-tries new-col-tries (or row-changed col-changed))))
|
|
'full-set
|
|
'caller))
|
|
|
|
; on 2002-10-17, I wrapped another layer of looping around the inner loop.
|
|
; the purpose of this outer loop is to allow the solver to ignore rows (or
|
|
; columns) about which the solver knows nothing for as long as possible.
|
|
|
|
(define (local-solve row-info col-info)
|
|
(let* ([rows (length row-info)]
|
|
[cols (length col-info)]
|
|
[initial-board (whole-first-pass row-info col-info cols rows)]
|
|
[_ (animate-changes initial-board draw-cols-thunk
|
|
(board-width initial-board)
|
|
(board-height initial-board))])
|
|
(let outer-loop ([outer-board initial-board]
|
|
[skip-threshold initial-threshold]
|
|
[old-row-tries (map (lambda (info)
|
|
(initial-num-possibilities info (board-width initial-board)))
|
|
row-info)]
|
|
[old-col-tries (map (lambda (info)
|
|
(initial-num-possibilities info (board-height initial-board)))
|
|
col-info)])
|
|
(let* ([row-try-list-list-opt-list (memoize-tries row-info cols outer-board old-row-tries skip-threshold)]
|
|
[col-try-list-list-opt-list (memoize-tries col-info rows (transpose outer-board) old-col-tries skip-threshold)])
|
|
(let loop ([board outer-board]
|
|
[row-tries row-try-list-list-opt-list]
|
|
[col-tries col-try-list-list-opt-list]
|
|
[changed #t])
|
|
(if changed
|
|
(call-with-values (lambda () (full-set board row-tries col-tries))
|
|
loop)
|
|
(if (finished? board)
|
|
board
|
|
(if (equal? outer-board board)
|
|
(outer-loop board (next-threshold skip-threshold) row-tries col-tries)
|
|
(outer-loop board skip-threshold row-tries col-tries)))))))))
|
|
|
|
)
|
|
(local-solve row-info col-info)
|
|
)))
|
|
|
|
|
|
; test case:
|
|
|
|
;(require solve)
|
|
;
|
|
;(let* ([test-board (build-vector 20 (lambda (x) (make-vector 20 'bad-value)))]
|
|
; [set-board! (lambda (col row val)
|
|
; (vector-set! (vector-ref test-board row) col val))])
|
|
; (solve `((9 9) (6 10) (5 11) (4 3 5) (2 1 3) (2 4 2) (1 3 6) (5 1 1 1) (2 2 1 3 1) (7 4 1) (7 4 2) (1 3 9) (1 2 4 6) (1 6 9) (1 4 7) (2 1 4 2) (5 3 4) (5 7) (5 10) (5 11))
|
|
; `((1 8) (2 4 4) (4 1 2 4) (8 2 4) (6 1 3 7) (4 8 4) (3 7 1) (1 2) (1 2) (2 2 2 1) (3 2 1 1 1 2) (7 8 2) (3 7 4 2) (3 1 1 2 3 3) (3 4 6 3) (4 1 4 3) (4 1 4 4) (5 1 4 4) (7 4 5) (7 6 5))
|
|
; set-board!
|
|
; (lambda (x) (void)))
|
|
; (equal? (map (lambda (row)
|
|
; (apply string-append
|
|
; (map (lambda (x)
|
|
; (case x
|
|
; [(off) " "]
|
|
; [(on) "x"]))
|
|
; row)))
|
|
; (apply map list (map vector->list (vector->list test-board))))
|
|
;
|
|
; `("x xxxxxxxx "
|
|
; "xx xxxx xxxx "
|
|
; "xxxx x xx xxxx"
|
|
; "xxxxxxxx xx xxxx"
|
|
; "xxxxxx x xxx xxxxxxx"
|
|
; "xxxx xxxxxxxx xxxx"
|
|
; "xxx xxxxxxx x"
|
|
; "x xx "
|
|
; "x xx "
|
|
; " xx xx xx x"
|
|
; " xxx xx x x x xx"
|
|
; "xxxxxxx xxxxxxxx xx"
|
|
; "xxx xxxxxxx xxxx xx"
|
|
; "xxx x x xx xxx xxx"
|
|
; "xxx xxxx xxxxxx xxx"
|
|
; "xxxx x xxxx xxx"
|
|
; "xxxx x xxxx xxxx"
|
|
; "xxxxx x xxxx xxxx"
|
|
; "xxxxxxx xxxx xxxxx"
|
|
; "xxxxxxx xxxxxx xxxxx")))
|