diff --git a/csp/csp.rkt b/csp/csp.rkt index 17976f9b..ff9d25cc 100644 --- a/csp/csp.rkt +++ b/csp/csp.rkt @@ -45,6 +45,9 @@ (raise-argument-error 'add-var! "var that doesn't exist" name)) (set-$csp-vars! csp (cons ($var name vals) ($csp-vars csp)))) +(define (unique-varnames? xs) + (and (andmap $var-name? xs) (not (check-duplicates xs eq?)))) + (define/contract (add-constraint! csp proc . var-names) (($csp? procedure?) #:rest (listof $var-name?) . ->* . void?) (for ([name (in-list var-names)]) @@ -73,7 +76,7 @@ (when (no-solutions? new-csp) (raise ($csp-inconsistent))) new-csp) -(define/contract (make-node-consistent csp) +(define/contract (make-nodes-consistent csp) ($csp? . -> . $csp?) (for/fold ([csp csp]) ([constraint (in-list ($csp-constraints csp))] @@ -134,7 +137,7 @@ ;; revision reduced the domain, so supplement the list of arcs (remove-duplicates (append (all-arcs . terminating-at . name) other-arcs)))))) -(define/contract (make-arc-consistent csp) +(define/contract (make-arcs-consistent csp) ($csp? . -> . $csp?) ;; csp is arc-consistent if every pair of variables (x y) ;; has values in their domain that satisfy every binary constraint @@ -200,11 +203,14 @@ (backtrack (infer (assign-val csp name val))))))] [else (raise ($csp-inconsistent))])) -(define/contract (solve csp) - ($csp? . -> . any/c) - (backtrack (make-arc-consistent (make-node-consistent csp)))) +(define/contract (solve csp [finish-proc values]) + (($csp?) (procedure?) . ->* . any/c) + (finish-proc (backtrack (make-arcs-consistent (make-nodes-consistent csp))))) + +(define ($csp-ref csp name) + (car ($csp-vals csp name))) (define/contract (alldiff . xs) (() #:rest (listof any/c) . ->* . boolean?) - (for*/and ([comb (in-combinations xs 2)]) + (for/and ([comb (in-combinations xs 2)]) (not (apply equal? comb)))) diff --git a/csp/test.rkt b/csp/test.rkt index c96495ff..af5d9171 100644 --- a/csp/test.rkt +++ b/csp/test.rkt @@ -1,4 +1,4 @@ -#lang racket +#lang at-exp racket (require "csp.rkt" rackunit) (let ([demo (new-csp)]) @@ -23,6 +23,8 @@ (add-constraint! demo three-or-less 'o) (check-equal? (solve demo) ($csp (list ($var 'o '(2)) ($var 'w '(1)) ($var 't '(0))) '()))) + +;; TWO + TWO = FOUR (define ttf (new-csp)) (define digs (range 10)) (add-var! ttf 't digs) @@ -44,4 +46,23 @@ (add-constraint! ttf positive? 'f) (add-constraint! ttf = 'f 'c1000) -(check-equal? (solve ttf) ($csp (list ($var 'c1000 '(1)) ($var 'c100 '(0)) ($var 'c10 '(0)) ($var 'r '(8)) ($var 'u '(6)) ($var 'f '(1)) ($var 'o '(4)) ($var 'w '(3)) ($var 't '(7))) '())) + +(define ttf-solution (solve ttf)) +(check-equal? ttf-solution + ($csp + (list + ($var 'c1000 '(1)) + ($var 'c100 '(0)) + ($var 'c10 '(0)) + ($var 'r '(8)) + ($var 'u '(6)) + ($var 'f '(1)) + ($var 'o '(4)) + ($var 'w '(3)) + ($var 't '(7))) + '())) + +(define (ttf-print csp) + (format "~a~a~a + ~a~a~a = ~a~a~a~a" ($csp-ref csp 't) ($csp-ref csp 'w) ($csp-ref csp 'o) ($csp-ref csp 't) ($csp-ref csp 'w) ($csp-ref csp 'o) ($csp-ref csp 'f) ($csp-ref csp 'o) ($csp-ref csp 'u) ($csp-ref csp 'r))) + +(check-equal? (solve ttf-solution ttf-print) "734 + 734 = 1468")