diff --git a/csp/csp.rkt b/csp/csp.rkt index de1bb04c..d8108a77 100644 --- a/csp/csp.rkt +++ b/csp/csp.rkt @@ -19,8 +19,8 @@ [else (match-define (cons name other-names) names) (for/and ([val (in-list ($csp-vals csp name))]) - ;; todo: reconsider efficiency of currying every value - (($constraint other-names (curry proc val)) csp))]))) + ;; todo: reconsider efficiency of currying every value + (($constraint other-names (curry proc val)) csp))]))) (define/contract (check-name-in-csp! caller csp name) (symbol? $csp? $var-name? . -> . void?) @@ -28,8 +28,7 @@ (unless (memq name names) (raise-argument-error caller (format "csp variable name: ~v" names) name))) -(define/contract (nary-constraint? constraint n) - ($constraint? exact-nonnegative-integer? . -> . boolean?) +(define (nary-constraint? constraint n) (= n (length ($constraint-names constraint)))) (define/contract (unary-constraint? constraint) @@ -40,31 +39,33 @@ ($constraint? . -> . boolean?) (nary-constraint? constraint 2)) -(define/contract (add-var! csp name [vals empty]) - (($csp? $var-name?) ((listof any/c)) . ->* . void?) - (add-vars! csp (list name) vals)) - -(define/contract (add-vars! csp names [vals empty]) - (($csp? (listof $var-name?)) ((listof any/c)) . ->* . void?) - (for ([name (in-list names)] - #:when (memq name (map $var-name ($csp-vars csp)))) - (raise-argument-error 'add-var! "var that doesn't exist" name)) - (for ([name (in-list names)]) - (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-vars! csp names [vals-or-procedure empty]) + (($csp? (listof $var-name?)) ((or/c (listof any/c) procedure?)) . ->* . void?) + (for/fold ([vars ($csp-vars csp)] + #:result (set-$csp-vars! csp vars)) + ([name (in-list names)]) + (when (memq name (map $var-name vars)) + (raise-argument-error 'add-vars! "var that doesn't exist" name)) + (append vars + (let ([vals (if (procedure? vals-or-procedure) + (vals-or-procedure) + vals-or-procedure)]) + (list ($var name vals)))))) + +(define/contract (add-var! csp name [vals-or-procedure empty]) + (($csp? $var-name?) ((or/c (listof any/c) procedure?)) . ->* . void?) + (add-vars! csp (list name) vals-or-procedure)) (define/contract (add-constraint! csp proc var-names) ($csp? procedure? (listof $var-name?) . -> . void?) (for ([name (in-list var-names)]) - (check-name-in-csp! 'add-constraint! csp name)) - (set-$csp-constraints! csp (cons ($constraint var-names proc) ($csp-constraints csp)))) + (check-name-in-csp! 'add-constraint! csp name)) + (set-$csp-constraints! csp (append ($csp-constraints csp) (list ($constraint var-names proc))))) (define/contract (no-solutions? csp) ($csp? . -> . boolean?) (for/or ([var (in-list ($csp-vars csp))]) - (empty? ($var-vals var)))) + (empty? ($var-vals var)))) (struct $csp-inconsistent () #:transparent) @@ -72,12 +73,12 @@ ($csp? unary-constraint? . -> . $csp?) (match-define ($constraint (list constraint-name) proc) constraint) (define new-csp ($csp (for/list ([var (in-list ($csp-vars csp))]) - (match-define ($var name vals) var) - (if (eq? name constraint-name) - ($var name (if (promise? proc) - (force proc) - (filter proc vals))) - var)) + (match-define ($var name vals) var) + (if (eq? name constraint-name) + ($var name (if (promise? proc) + (force proc) + (filter proc vals))) + var)) ;; once the constraint is applied, it can go away (remove constraint ($csp-constraints csp)))) (when (no-solutions? new-csp) (raise ($csp-inconsistent))) @@ -95,11 +96,11 @@ (check-name-in-csp! '$csp-vals csp name) (for/first ([var (in-list ($csp-vars csp))] #:when (eq? name ($var-name var))) - ($var-vals var))) + ($var-vals var))) (struct $arc (name constraint) #:transparent) -(define/contract (revise csp arc) +(define/contract (reduce-domains-by-arc csp arc) ($csp? $arc? . -> . $csp?) (match-define ($arc name ($constraint names constraint-proc)) arc) (match-define (list other-name) (remove name names)) @@ -108,7 +109,7 @@ (λ (val other-val) (constraint-proc other-val val)))) ; otherwise reverse arg order (define (satisfies-arc? val) (for/or ([other-val (in-list ($csp-vals csp other-name))]) - (proc val other-val))) + (proc val other-val))) (apply-unary-constraint csp ($constraint (list name) (procedure-rename satisfies-arc? @@ -118,30 +119,26 @@ ((listof binary-constraint?) . -> . (listof $arc?)) (for*/list ([constraint (in-list constraints)] [name (in-list ($constraint-names constraint))]) - ($arc name constraint))) + ($arc name constraint))) (define/contract (terminating-at arcs name) ((listof $arc?) $var-name? . -> . (listof $arc?)) (for/list ([arc (in-list arcs)] #:when (eq? name (second ($constraint-names ($arc-constraint arc))))) - arc)) - -(define/contract (constraint-names-assigned? csp constraint) - ($csp? $constraint? . -> . boolean?) - (define assigned-var-names - (for/list ([var (in-list (assigned-vars csp))]) - ($var-name var))) - (match-define ($constraint names _) constraint) - (for/and ([name (in-list names)]) - (memq name assigned-var-names))) - -(define/contract (remove-obsolete-constraints csp) + arc)) + +(define/contract (constraint-assigned? csp constraint) + ($csp? $constraint? . -> . any/c) + (for/and ([name (in-list ($constraint-names constraint))]) + (memq name (map $var-name (assigned-vars csp))))) + +(define/contract (remove-assigned-constraints csp) ($csp? . -> . $csp?) ($csp ($csp-vars csp) (for/list ([constraint (in-list ($csp-constraints csp))] - #:unless (constraint-names-assigned? csp constraint)) - constraint))) + #:unless (constraint-assigned? csp constraint)) + constraint))) (define/contract (ac-3 csp) ($csp? . -> . $csp?) @@ -149,13 +146,13 @@ (define all-arcs (binary-constraints->arcs (filter binary-constraint? ($csp-constraints csp)))) (for/fold ([csp csp] [arcs all-arcs] - #:result (remove-obsolete-constraints csp)) + #:result (remove-assigned-constraints csp)) ([i (in-naturals)] #:break (empty? arcs)) (match-define (cons arc other-arcs) arcs) (match-define ($arc name _) arc) - (define revised-csp (revise csp arc)) - (values revised-csp (if (= (length ($csp-vals csp name)) (length ($csp-vals revised-csp name))) + (define reduced-csp (reduce-domains-by-arc csp arc)) + (values reduced-csp (if (= (length ($csp-vals csp name)) (length ($csp-vals reduced-csp name))) ;; revision did not reduce the domain, so keep going other-arcs ;; revision reduced the domain, so supplement the list of arcs @@ -189,10 +186,10 @@ (define/contract (select-unassigned-var csp) ($csp? . -> . $var?) - ;; minimum remaining values (MRV) rule (define uvars (unassigned-vars csp)) (when (empty? uvars) - (raise-argument-error 'select-unassigned-var "nonempty list of vars" uvars)) + (raise-argument-error 'select-unassigned-var "csp with unassigned vars" csp)) + ;; minimum remaining values (MRV) rule (argmin (λ (var) (length ($var-vals var))) uvars)) (define/contract (order-domain-values vals) @@ -203,57 +200,46 @@ ;; todo: inferences between assignments (define infer values) +(define/contract (constraint-has-name? constraint name) + ($constraint? $var-name? . -> . boolean?) + (and (memq name ($constraint-names constraint)) #true)) + (define/contract (assign-val csp name val) ($csp? $var-name? any/c . -> . $csp?) - (validate-assignment (apply-unary-constraint csp ($constraint (list name) (delay (list val)))) name)) - -(define/contract (validate-assignment csp name) - ($csp? $var-name? . -> . $csp?) - (define assigned-names (map $var-name (assigned-vars csp))) - (for/fold ([csp csp]) + (define csp-with-assignment (apply-unary-constraint csp ($constraint (list name) (delay (list val))))) + (for/fold ([csp csp-with-assignment]) ([constraint (in-list ($csp-constraints csp))] - #:when (match-let ([($constraint cnames _) constraint]) - (and (memq name cnames) - (for/and ([cname (in-list cnames)]) - (memq cname assigned-names))))) + #:when (and (constraint-has-name? constraint name) + (constraint-assigned? csp constraint))) (unless (constraint csp) (raise ($csp-inconsistent))) - (remove-obsolete-constraints csp))) + (remove-assigned-constraints csp))) -(define solver-stop-val (gensym 'solver-stop)) -(define/contract (backtracking-solution-generator csp) +(define/contract (backtracking-solver csp) ($csp? . -> . generator?) (generator () - (begin0 - solver-stop-val - (let backtrack ([csp csp]) - (cond - [(assignment-complete? csp) (yield csp)] - [else ;; we have at least 1 unassigned var - (match-define ($var name vals) (select-unassigned-var csp)) - (for ([val (in-list (order-domain-values vals))]) - (with-handlers ([$csp-inconsistent? (const #f)]) - (backtrack (infer (assign-val csp name val)))))]))))) - -(define (backtracking-solver csp) - (backtracking-solution-generator (make-arcs-consistent (make-nodes-consistent csp)))) - -(define/contract (solve csp [finish-proc values]) - (($csp?) (procedure?) . ->* . any/c) - (or - (for/first ([solution (in-producer (backtracking-solver csp) solver-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 (backtracking-solver csp) solver-stop-val)]) - (finish-proc solution))) - (when (empty? solutions) (raise ($csp-inconsistent))) + (let backtrack ([csp (make-arcs-consistent (make-nodes-consistent csp))]) + (cond + [(assignment-complete? csp) (yield csp)] + [else ;; we have at least 1 unassigned var + (match-define ($var name vals) (select-unassigned-var csp)) + (for ([val (in-list (order-domain-values vals))]) + (with-handlers ([$csp-inconsistent? (const #f)]) + (backtrack (infer (assign-val csp name val)))))])))) + +(define/contract (solve* csp [finish-proc values][solution-limit +inf.0]) + (($csp?) (procedure? integer?) . ->* . (listof any/c)) + (define solutions + (for/list ([solution (in-producer (backtracking-solver csp) (void))] + [idx (in-range solution-limit)]) + (finish-proc solution))) + (unless (pair? solutions) (raise ($csp-inconsistent))) solutions) +(define/contract (solve csp [finish-proc values]) + (($csp?) (procedure?) . ->* . any/c) + (first (solve* csp finish-proc 1))) -(define ($csp-ref csp name) - (car ($csp-vals csp name))) +(define ($csp-ref csp name) (car ($csp-vals csp name))) (define/contract (alldiff . xs) (() #:rest (listof any/c) . ->* . boolean?) diff --git a/csp/test.rkt b/csp/test.rkt index e482e9be..5d5a1c2b 100644 --- a/csp/test.rkt +++ b/csp/test.rkt @@ -10,17 +10,17 @@ (add-constraint! demo alldiff '(t w o)) (add-constraint! demo < '(t w o)) -(check-equal? (solve demo) ($csp (list ($var 'o '(2)) ($var 'w '(1)) ($var 't '(0))) '())) +(check-equal? (time (solve demo)) ($csp (list ($var 't '(0)) ($var 'w '(1)) ($var 'o '(2))) '())) ;; TWO + TWO = FOUR (define ttf (make-csp)) -(add-vars! ttf '(t w o f u r) (range 10)) +(add-vars! ttf '(t w o f u r) (reverse (range 10))) (define (word-value . xs) (let ([xs (reverse xs)]) (for/sum ([i (in-range (length xs))]) - (* (list-ref xs i) (expt 10 i))))) + (* (list-ref xs i) (expt 10 i))))) (add-constraint! ttf alldiff '(t w o f u r)) (add-constraint! ttf (λ (t w o f u r) (= (+ (word-value t w o) (word-value t w o)) @@ -28,22 +28,22 @@ (add-constraint! ttf positive? '(t)) (add-constraint! ttf positive? '(f)) -(define ttf-solution (solve ttf)) +(define ttf-solution (time (solve ttf))) (check-equal? ttf-solution ($csp (list - ($var 'r '(0)) - ($var 'u '(3)) + ($var 't '(9)) + ($var 'w '(3)) + ($var 'o '(8)) ($var 'f '(1)) - ($var 'o '(5)) - ($var 'w '(6)) - ($var 't '(7))) + ($var 'u '(7)) + ($var 'r '(6))) '())) (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) "765 + 765 = 1530") +(check-equal? (time (solve ttf-solution ttf-print)) "938 + 938 = 1876") ;; ABC problem: @@ -61,11 +61,11 @@ (/ (+ (* 100 a) (* 10 b) c) (+ a b c)))) -(define abc-sols (solve* abc)) +(define abc-sols (time (solve* abc))) (check-equal? (* 9 9 9) (length abc-sols)) (check-equal? (argmin solution-score abc-sols) - ($csp (list ($var 'c '(9)) ($var 'b '(9)) ($var 'a '(1))) '())) + ($csp (list ($var 'a '(1)) ($var 'b '(9)) ($var 'c '(9))) '())) ;; quarter problem: @@ -76,8 +76,8 @@ (add-vars! quarter-problem '(dollars quarters) (range 26)) (add-constraint! quarter-problem (λ (d q) (= 26 (+ d q))) '(dollars quarters)) (add-constraint! quarter-problem (λ (d q) (= 17 (+ d (* 0.25 q)))) '(dollars quarters)) -(check-equal? (solve quarter-problem) - ($csp (list ($var 'quarters '(12)) ($var 'dollars '(14))) '())) +(check-equal? (time (solve quarter-problem)) + ($csp (list ($var 'dollars '(14)) ($var 'quarters '(12))) '())) ;; nickel problem @@ -90,8 +90,8 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu (add-constraint! ndq-problem (λ (n d q) (= 330 (+ (* n 5) (* d 10) (* q 25)))) '(n d q)) (add-constraint! ndq-problem (λ (n q) (= (* 3 q) n)) '(n q)) (add-constraint! ndq-problem (λ (d n) (= (* 2 d) n)) '(d n)) -(check-equal? (solve ndq-problem) - ($csp (list ($var 'q '(6)) ($var 'd '(9)) ($var 'n '(18))) '())) +(check-equal? (time (solve ndq-problem)) + ($csp (list ($var 'n '(18)) ($var 'd '(9)) ($var 'q '(6))) '())) ;; xsum @@ -109,16 +109,14 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu (define xsum-problem (make-csp)) (add-vars! xsum-problem '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 1 10)) -(add-constraint! xsum-problem (λ (l1 l2 l3 l4 x) - (and (< l1 l2 l3 l4) - (= 27 (+ l1 l2 l3 l4 x)))) '(l1 l2 l3 l4 x)) -(add-constraint! xsum-problem (λ (r1 r2 r3 r4 x) - (and (< r1 r2 r3 r4) - (= 27 (+ r1 r2 r3 r4 x)))) '(r1 r2 r3 r4 x)) +(add-constraint! xsum-problem < '(l1 l2 l3 l4)) +(add-constraint! xsum-problem < '(r1 r2 r3 r4)) +(add-constraint! xsum-problem (λ (l1 l2 l3 l4 x) (= 27 (+ l1 l2 l3 l4 x))) '(l1 l2 l3 l4 x)) +(add-constraint! xsum-problem (λ (r1 r2 r3 r4 x) (= 27 (+ r1 r2 r3 r4 x))) '(r1 r2 r3 r4 x)) (add-constraint! xsum-problem alldiff '(l1 l2 l3 l4 r1 r2 r3 r4 x)) ;; todo: too slow -#;(check-equal? (length (solve* xsum-problem)) 8) +#;(check-equal? (length (time (solve* xsum-problem))) 8) ;; send more money problem @@ -138,7 +136,7 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu (add-constraint! smm positive? '(m)) (add-constraint! smm (λ (s e n d m o r y) (= (+ (word-value s e n d) (word-value m o r e)) - (word-value m o n e y))) '(s e n d m o r y)) + (word-value m o n e y))) '(s e n d m o r y)) (add-constraint! smm alldiff '(s e n d m o r y)) ;; todo: too slow @@ -153,12 +151,12 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu (for* ([(qa qa-col) (in-indexed queens)] [(qb qb-col) (in-indexed queens)] #:when (< qa-col qb-col)) - (add-constraint! queens-problem - (λ (qa-row qb-row) - (and - (not (= (abs (- qa-row qb-row)) (abs (- qa-col qb-col)))) ; same diagonal? - (not (= qa-row qb-row)))) ; same row? - (list qa qb))) + (add-constraint! queens-problem + (λ (qa-row qb-row) + (and + (not (= (abs (- qa-row qb-row)) (abs (- qa-col qb-col)))) ; same diagonal? + (not (= qa-row qb-row)))) ; same row? + (list qa qb))) (check-equal? 92 (length (solve* queens-problem)))