diff --git a/csp/csp.rkt b/csp/csp.rkt index 4cb60a81..6515f2ae 100644 --- a/csp/csp.rkt +++ b/csp/csp.rkt @@ -1,4 +1,5 @@ #lang debug racket +(require racket/generator) (provide (all-defined-out)) (struct $csp ([vars #:mutable] [constraints #:mutable]) #:transparent) @@ -198,32 +199,36 @@ (unless (constraint csp) (raise ($csp-inconsistent))) ($csp ($csp-vars csp) (remove constraint ($csp-constraints csp))))) -(define/contract (backtrack csp) - ($csp? . -> . $csp?) - (cond - [(assignment-complete? csp) csp] - [(match-let ([($var name vals) (select-unassigned-var csp)]) - (for/or ([val (in-list (order-domain-values vals))]) - (with-handlers ([$csp-inconsistent? (λ (exn) #f)]) - (backtrack (infer (assign-val csp name val))))))] - [else (raise ($csp-inconsistent))])) - -(define/contract (solve csp [finish-proc values]) - (($csp?) (procedure?) . ->* . any/c) - (finish-proc (backtrack (make-arcs-consistent (make-nodes-consistent csp))))) - -(require racket/generator) +(define gen-stop-val (gensym)) (define/contract (backtrack-solver csp) ($csp? . -> . generator?) (generator () - (let loop ([csp csp]) + (let backtrack ([csp csp]) (cond [(assignment-complete? csp) (yield csp)] [else (match-define ($var name vals) (select-unassigned-var csp)) (for ([val (in-list (order-domain-values vals))]) (with-handlers ([$csp-inconsistent? (λ (exn) #f)]) - (loop (infer (assign-val csp name val)))))])))) + (backtrack (infer (assign-val csp name val))))) + gen-stop-val])))) + +(define (make-backtrack-iterator csp) + (backtrack-solver (make-arcs-consistent (make-nodes-consistent csp)))) + +(define/contract (solve csp [finish-proc values]) + (($csp?) (procedure?) . ->* . any/c) + (or + (for/first ([solution (in-producer (make-backtrack-iterator csp) gen-stop-val)]) + (finish-proc solution)) + (raise ($csp-inconsistent)))) + +(define/contract (solve* csp [finish-proc values]) + (($csp?) (procedure?) . ->* . (listof any/c)) + (define solutions (for/list ([solution (in-producer (make-backtrack-iterator csp) gen-stop-val)]) + (finish-proc solution))) + (when (empty? solutions) (raise ($csp-inconsistent))) + solutions) (define ($csp-ref csp name) (car ($csp-vals csp name))) diff --git a/csp/test.rkt b/csp/test.rkt index 7ee0304b..7f3bef70 100644 --- a/csp/test.rkt +++ b/csp/test.rkt @@ -52,21 +52,13 @@ ;; A+B+C (define abc (make-csp)) -(add-vars! abc '(a b c) (range 1 3)) -(define (test-solution abc) +(add-vars! abc '(a b c) (range 1 10)) +(define (solution-score abc) (let ([a ($csp-ref abc 'a)] [b ($csp-ref abc 'b)] [c ($csp-ref abc 'c)]) (/ (+ (* 100 a) (* 10 b) c) (+ a b c)))) - -;; todo: gather all solutins in generator -(define bs (backtrack-solver abc)) -(bs) -(bs) -(bs) -(bs) -(bs) -(bs) -(bs) -(bs) \ No newline at end of file +(check-equal? + (argmin solution-score (solve* abc)) + ($csp (list ($var 'c '(9)) ($var 'b '(9)) ($var 'a '(1))) '())) \ No newline at end of file