You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/csp/solver.rkt

107 lines
4.5 KiB
Racket

10 years ago
#lang racket/base
10 years ago
(require racket/class sugar/container sugar/debug racket/list
racket/bool racket/generator racket/match "helper.rkt")
10 years ago
(provide (all-defined-out))
(define solver%
10 years ago
;; Abstract base class for solvers
(class object%
(super-new)
(abstract get-solution)
(abstract get-solutions)
(abstract get-solution-iter)))
10 years ago
(define solver%? (is-a?/c solver%))
10 years ago
10 years ago
(struct vvp (variable values pushdomains))
10 years ago
(define-syntax-rule (pop-vvp-values! vvps)
10 years ago
(if (null? vvps)
(error 'pop-vvp-values! (format "~a is null" vvps))
(let ([vvp (car vvps)])
(set! vvps (cdr vvps))
(values (vvp-variable vvp) (vvp-values vvp) (vvp-pushdomains vvp)))))
10 years ago
(define backtracking-solver%
10 years ago
;; Problem solver with backtracking capabilities
(class solver%
10 years ago
(super-new)
(init-field [forwardcheck #t])
(field [_forwardcheck forwardcheck])
(define/override (get-solution-iter domains constraints vconstraints)
(define sorted-variables
(map last (sort (for/list ([(variable domain) (in-hash domains)])
(list (- (length (hash-ref vconstraints variable))) ; first two elements used for sorting
(length (domain))
variable)) list-comparator)))
10 years ago
;; state-retention variables
10 years ago
(define possible-solution (make-hash))
(define variable-queue null)
10 years ago
(define variable #f)
10 years ago
(define values null)
(define pushdomains null)
10 years ago
10 years ago
(define (get-next-unassigned-variable)
(for/first ([sorted-variable (in-list sorted-variables)]
#:unless (hash-has-key? possible-solution sorted-variable))
(set! variable sorted-variable)
10 years ago
(set! values ((hash-ref domains variable)))
(set! pushdomains
(if _forwardcheck
(for/list ([(var domain) (in-hash domains)]
10 years ago
#:unless (and (equal? variable var)
(hash-has-key? possible-solution var)))
10 years ago
domain)
null))
variable))
10 years ago
(define (set!-previous-variable)
10 years ago
(set!-values (variable values pushdomains) (pop-vvp-values! variable-queue))
(for-each-send pop-state pushdomains))
10 years ago
(let/ec exit-k
10 years ago
;; mix the degree and minimum-remaining-values (MRV) heuristics
10 years ago
(let main-loop ()
10 years ago
(unless (get-next-unassigned-variable)
10 years ago
(yield (hash-copy possible-solution)) ; if there are no unassigned variables, solution is done.
(if (null? variable-queue) ; if queue isn't empty, return to previous variable, otherwise all done.
(exit-k)
10 years ago
(set!-previous-variable)))
10 years ago
10 years ago
(let value-checking-loop () ; we have a variable. Do we have any values left?
(when (null? values) ; no, so try going back to last variable and getting some values
10 years ago
(for/or ([i (in-naturals)])
10 years ago
(when (null? variable-queue) (exit-k)) ; no variables left, so solver is done
(hash-remove! possible-solution variable)
10 years ago
(set!-previous-variable)
10 years ago
(not (null? values))))
10 years ago
;; Got a value. Check it.
10 years ago
(hash-set! possible-solution variable (car-pop! values))
10 years ago
(for-each-send push-state pushdomains)
(when (for/or ([cvpair (in-list (hash-ref vconstraints variable))])
(match-define (list constraint variables) cvpair)
10 years ago
(not (send constraint broken? variables domains possible-solution pushdomains)))
10 years ago
;; constraint failed, so try again
(for-each-send pop-state pushdomains)
10 years ago
(value-checking-loop)))
10 years ago
;; Push state before looking for next variable.
10 years ago
(set! variable-queue (cons (vvp variable values pushdomains) variable-queue))
10 years ago
(main-loop))
10 years ago
(error 'get-solution-iter "impossible to reach this"))
10 years ago
(void))
10 years ago
(define (call-solution-generator domains constraints vconstraints #:first-only [first-only #f])
(for/list ([solution (in-generator (get-solution-iter domains constraints vconstraints))] #:final first-only)
10 years ago
solution))
(define/override (get-solution . args)
10 years ago
(car (apply call-solution-generator #:first-only #t args)))
(define/override (get-solutions . args)
(apply call-solution-generator args))))
(define backtracking-solver%? (is-a?/c backtracking-solver%))