diff --git a/csp/csp.rkt b/csp/csp.rkt index 807ac685..4cb60a81 100644 --- a/csp/csp.rkt +++ b/csp/csp.rkt @@ -197,7 +197,6 @@ (memq cname assigned-names))))) (unless (constraint csp) (raise ($csp-inconsistent))) ($csp ($csp-vars csp) (remove constraint ($csp-constraints csp))))) - (define/contract (backtrack csp) ($csp? . -> . $csp?) @@ -213,6 +212,19 @@ (($csp?) (procedure?) . ->* . any/c) (finish-proc (backtrack (make-arcs-consistent (make-nodes-consistent csp))))) +(require racket/generator) +(define/contract (backtrack-solver csp) + ($csp? . -> . generator?) + (generator () + (let loop ([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)))))])))) + (define ($csp-ref csp name) (car ($csp-vals csp name))) diff --git a/csp/test.rkt b/csp/test.rkt index 5d9a1fc1..7ee0304b 100644 --- a/csp/test.rkt +++ b/csp/test.rkt @@ -52,11 +52,21 @@ ;; A+B+C (define abc (make-csp)) -(add-vars! abc '(a b c) (range 1 10)) -(define (test-solution s) (let ([a (car ($csp-vals abc 'a))] - [b (car ($csp-vals abc 'b))] - [c (car ($csp-vals abc 'c))]) - (/ (+ (* 100 a) (* 10 b) c) (+ a b c)))) +(add-vars! abc '(a b c) (range 1 3)) +(define (test-solution 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 -(test-solution (solve abc)) \ No newline at end of file +(define bs (backtrack-solver abc)) +(bs) +(bs) +(bs) +(bs) +(bs) +(bs) +(bs) +(bs) \ No newline at end of file