diff --git a/csp/csp.rkt b/csp/csp.rkt index c2914034..4963429c 100644 --- a/csp/csp.rkt +++ b/csp/csp.rkt @@ -42,17 +42,18 @@ ($constraint? . -> . boolean?) (nary-constraint? constraint 2)) -(define/contract (add-vars! csp names [vals-or-procedure empty]) - (($csp? (listof $var-name?)) ((or/c (listof any/c) procedure?)) . ->* . void?) +(define/contract (add-vars! csp names-or-procedure [vals-or-procedure empty]) + (($csp? (or/c (listof $var-name?) procedure?)) ((or/c (listof any/c) procedure?)) . ->* . void?) (for/fold ([vars ($csp-vars csp)] #:result (set-$csp-vars! csp vars)) - ([name (in-list names)]) + ([name (in-list (if (procedure? names-or-procedure) + (names-or-procedure) + names-or-procedure))]) (when (memq name (map $var-name vars)) (raise-argument-error 'add-vars! "var that doesn't already exist" name)) - (define vals (if (procedure? vals-or-procedure) - (vals-or-procedure) - vals-or-procedure)) - (append vars (list ($var name vals))))) + (append vars (list ($var name (if (procedure? vals-or-procedure) + (vals-or-procedure) + vals-or-procedure)))))) (define/contract (add-var! csp name [vals-or-procedure empty]) (($csp? $var-name?) ((or/c (listof any/c) procedure?)) . ->* . void?) @@ -84,24 +85,29 @@ (define/contract (apply-unary-constraint csp constraint) ($csp? unary-constraint? . -> . $csp?) - (match-define ($constraint (list cname) proc) constraint) - (define new-csp ($csp (for/list ([var (in-list ($csp-vars csp))]) - (match-define ($var name vals) var) - (cond - [(eq? name cname) - ;; special rule: use promise for a constant value - ;; to skip the filtering - ($var name (if (promise? proc) - (force proc) - (filter proc vals)))] - [else var])) - ;; once the constraint is applied, it can go away - ;; ps this is not the same as an "assigned" constraint - ;; because the var may still have multiple values - (remove constraint ($csp-constraints csp)))) - (if (assigned-name? new-csp cname) - (validate-assignments (make-arcs-consistent new-csp #:mac cname)) - new-csp)) + (define (update-csp-vars name vals) + (for/list ([var (in-list ($csp-vars csp))]) + (if (eq? ($var-name var) name) + ($var name vals) + var))) + (match-define ($constraint (list name) proc) constraint) + (match (if (promise? proc) + (force proc) + (filter proc ($csp-vals csp name))) + [(list) (raise (inconsistency-signal))] + [(list assigned-val) (make-nodes-consistent + (remove-assigned-constraints + (reduce-constraint-arity + (validate-assignments + (make-arcs-consistent + ($csp + (update-csp-vars name (list assigned-val)) + ($csp-constraints csp)) #:mac name)))))] + [(list new-vals ...) ($csp (update-csp-vars name new-vals) + ;; once the constraint is applied, it can go away + ;; ps this is not the same as an "assigned" constraint + ;; because the var may still have multiple values + (remove constraint ($csp-constraints csp)))])) (define/contract (make-nodes-consistent csp) ($csp? . -> . $csp?) @@ -160,9 +166,6 @@ (constraint-assigned? csp constraint))) constraint))) -(define (remove-assigned-binary-constraints csp) - (remove-assigned-constraints csp 2)) - (define/contract (make-arcs-consistent csp #:mac [mac-name #f]) (($csp?) (#:mac (or/c $var-name? #f)) . ->* . $csp?) ;; csp is arc-consistent if every pair of variables (x y) @@ -221,22 +224,27 @@ 1)) (define/contract (select-unassigned-var csp) - ($csp? . -> . $var?) - (define uvars (unassigned-vars csp)) - (when (empty? uvars) - (raise-argument-error 'select-unassigned-var "csp with unassigned vars" csp)) - ;; minimum remaining values (MRV) rule - (define uvars-by-rv (sort uvars < #:key remaining-values)) - (define minimum-remaining-values (remaining-values (first uvars-by-rv))) - (match (takef uvars-by-rv (λ (var) (= minimum-remaining-values (remaining-values var)))) - [(list winning-uvar) winning-uvar] - [(list mrv-uvars ...) ;; use degree as tiebreaker - (argmax (λ (var) (var-degree csp var)) mrv-uvars)])) + ($csp? . -> . (or/c #f $var?)) + (match (unassigned-vars csp) + [(list) #f] + [(list uvars ...) + ;; minimum remaining values (MRV) rule + (define uvars-by-rv (sort uvars < #:key remaining-values)) + (define minimum-remaining-values (remaining-values (first uvars-by-rv))) + (match (takef uvars-by-rv (λ (var) (= minimum-remaining-values (remaining-values var)))) + [(list winning-uvar) winning-uvar] + [(list mrv-uvars ...) + ;; use degree as tiebreaker for mrv + (define uvars-by-degree (sort mrv-uvars > #:key (λ (var) (var-degree csp var)))) + (define max-degree (var-degree csp (first uvars-by-degree))) + ;; use random tiebreaker for degree + (match (takef uvars-by-degree (λ (var) (= max-degree (var-degree csp var)))) + [(list winning-uvar) winning-uvar] + [(list degree-uvars ...) (first (shuffle degree-uvars))])])])) (define/contract (order-domain-values vals) ((listof any/c) . -> . (listof any/c)) ;; todo: least constraining value sort - vals) (define/contract (constraint-contains-name? constraint name) @@ -249,7 +257,7 @@ (for ([constraint (in-list (sort assigned-constraints < #:key constraint-arity))] #:unless (constraint csp)) (raise (inconsistency-signal))) - (reduce-constraint-arity (remove-assigned-constraints csp))) + csp) (define/contract (assign-val csp name val) ($csp? $var-name? any/c . -> . $csp?) @@ -278,28 +286,19 @@ (values (cons (car vals) acc) xs (cdr vals)))))) reduced-arity-name)) -(module+ test - (require rackunit) - (define f (λ (a b c d) (+ a b c d))) - (check-equal? 10 ((reduce-arity f '(1 b c d)) 2 3 4)) - (check-equal? 10 ((reduce-arity f '(1 2 c d)) 3 4)) - (check-equal? 10 ((reduce-arity f '(1 2 3 d)) 4)) - (check-equal? 10 ((reduce-arity f '(1 b 3 d)) 2 4)) - (check-equal? 10 ((reduce-arity f '(a b 3 d)) 1 2 4))) - (define/contract (assigned-name? csp name) ($csp? $var-name? . -> . boolean?) (and (memq name (map $var-name (assigned-vars csp))) #true)) -(define/contract (reduce-constraint-arity csp [minimum-arity 3]) - (($csp?) (exact-nonnegative-integer?) . ->* . $csp?) +(define/contract (reduce-constraint-arity csp [minimum-arity #false]) + (($csp?) ((or/c #false exact-nonnegative-integer?)) . ->* . $csp?) (let ([assigned-name? (curry assigned-name? csp)]) (define (partially-assigned? constraint) (ormap assigned-name? ($constraint-names constraint))) ($csp ($csp-vars csp) (for/list ([constraint (in-list ($csp-constraints csp))]) (cond - [(and (<= minimum-arity (constraint-arity constraint)) + [(and (if minimum-arity (<= minimum-arity (constraint-arity constraint)) #true) (partially-assigned? constraint)) (match-define ($constraint cnames proc) constraint) ($constraint (filter-not assigned-name? cnames) @@ -311,30 +310,21 @@ (reduce-arity proc reduce-arity-pattern)))] [else constraint]))))) -(module+ test - (define creduce (assign-val ($csp (list ($var 'a '(1 2 3)) ($var 'b '(2 3)) ($var 'c '(1 2 3 4 5))) (list ($constraint '(a b c) (procedure-rename (λ (a b c) (= (+ a b c) 4)) 'summer)))) 'a 1)) - (check-equal? - (make-arcs-consistent (reduce-constraint-arity creduce)) - ($csp (list ($var 'a '(1)) ($var 'b '(2)) ($var 'c '(1))) '()))) - - -(define/contract (backtracking-solver csp) - ($csp? . -> . generator?) +(define/contract (in-solutions csp) + ($csp? . -> . sequence?) ;; as described by AIMA @ 271 - (generator () - (let backtrack ([csp (make-arcs-consistent (make-nodes-consistent csp))]) - (cond - [(solution-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 ([inconsistency-signal? void]) - (backtrack (assign-val csp name val))))])))) + (in-generator (let backtrack ([csp (make-arcs-consistent (make-nodes-consistent csp))]) + (match (select-unassigned-var csp) + [#f (yield csp)] + [($var name vals) + (for ([val (in-list (order-domain-values vals))]) + (with-handlers ([inconsistency-signal? void]) + (backtrack (assign-val csp name val))))])))) (define/contract (solve* csp [finish-proc values][solution-limit +inf.0]) - (($csp?) (procedure? integer?) . ->* . (listof any/c)) + (($csp?) (procedure? integer?) . ->* . (non-empty-listof any/c)) (define solutions - (for/list ([solution (in-producer (backtracking-solver csp) (void))] + (for/list ([solution (in-solutions csp)] [idx (in-range solution-limit)]) (finish-proc solution))) (unless (pair? solutions) (raise (inconsistency-signal))) diff --git a/csp/main.rkt b/csp/main.rkt index 73d16dac..f4d54358 100644 --- a/csp/main.rkt +++ b/csp/main.rkt @@ -1,13 +1,4 @@ #lang racket/base -(require - "problem.rkt" - "constraint.rkt" - "solver.rkt" - "helper.rkt") - -(provide (all-from-out - "problem.rkt" - "constraint.rkt" - "solver.rkt" - "helper.rkt")) +(require "port/main.rkt") +(provide (all-from-out "port/main.rkt")) diff --git a/csp/constraint.rkt b/csp/port/constraint.rkt similarity index 100% rename from csp/constraint.rkt rename to csp/port/constraint.rkt diff --git a/csp/domain.rkt b/csp/port/domain.rkt similarity index 100% rename from csp/domain.rkt rename to csp/port/domain.rkt diff --git a/csp/helper.rkt b/csp/port/helper.rkt similarity index 100% rename from csp/helper.rkt rename to csp/port/helper.rkt diff --git a/csp/port/main.rkt b/csp/port/main.rkt new file mode 100644 index 00000000..73d16dac --- /dev/null +++ b/csp/port/main.rkt @@ -0,0 +1,13 @@ +#lang racket/base +(require + "problem.rkt" + "constraint.rkt" + "solver.rkt" + "helper.rkt") + +(provide (all-from-out + "problem.rkt" + "constraint.rkt" + "solver.rkt" + "helper.rkt")) + diff --git a/csp/problem.rkt b/csp/port/problem.rkt similarity index 100% rename from csp/problem.rkt rename to csp/port/problem.rkt diff --git a/csp/solver.rkt b/csp/port/solver.rkt similarity index 100% rename from csp/solver.rkt rename to csp/port/solver.rkt diff --git a/csp/test-classes.rkt b/csp/port/test-classes.rkt similarity index 100% rename from csp/test-classes.rkt rename to csp/port/test-classes.rkt diff --git a/csp/test-einstein.rkt b/csp/port/test-einstein.rkt similarity index 100% rename from csp/test-einstein.rkt rename to csp/port/test-einstein.rkt diff --git a/csp/port/test-problems.rkt b/csp/port/test-problems.rkt new file mode 100644 index 00000000..7913fb4e --- /dev/null +++ b/csp/port/test-problems.rkt @@ -0,0 +1,130 @@ +#lang racket +(require "main.rkt" "test-classes.rkt") +(require rackunit) + + +;; ABC problem: +;; what is the minimum value of + +;; ABC +;; ------- +;; A+B+C + + +(define abc-problem (new problem%)) +(send abc-problem add-variables '("a" "b" "c") (range 1 10)) +(define (test-solution s) (let ([a (hash-ref s "a")] + [b (hash-ref s "b")] + [c (hash-ref s "c")]) + (/ (+ (* 100 a) (* 10 b) c) (+ a b c)))) + +(check-hash-items (argmin test-solution (send abc-problem get-solutions)) + #hash(("c" . 9) ("b" . 9) ("a" . 1))) + + +;; quarter problem: +;; 26 coins, dollars and quarters +;; that add up to $17. + +(define quarter-problem (new problem%)) +(send quarter-problem add-variables '("dollars" "quarters") (range 1 27)) +(send quarter-problem add-constraint (λ(d q) (= 17 (+ d (* 0.25 q)))) '("dollars" "quarters")) +(send quarter-problem add-constraint (λ(d q) (= 26 (+ d q))) '("dollars" "quarters")) +(check-hash-items (send quarter-problem get-solution) '#hash(("dollars" . 14) ("quarters" . 12))) + +;; coin problem 2 +#| +A collection of 33 coins, consisting of nickels, dimes, and quarters, has a value of $3.30. If there are three times as many nickels as quarters, and one-half as many dimes as nickels, how many coins of each kind are there? +|# + +(define nickel-problem (new problem%)) +(send nickel-problem add-variables '(nickels dimes quarters) (range 1 34)) +(send nickel-problem add-constraint (λ(n d q) (= 33 (+ n d q))) '(nickels dimes quarters)) +(send nickel-problem add-constraint (λ(n d q) (= 3.30 (+ (* 0.05 n) (* 0.1 d) (* 0.25 q)))) '(nickels dimes quarters)) +(send nickel-problem add-constraint (λ(n q) (= n (* 3 q))) '(nickels quarters)) +(send nickel-problem add-constraint (λ(d n) (= n (* 2 d))) '(dimes nickels)) +(check-hash-items (send nickel-problem get-solution) #hash((nickels . 18) (quarters . 6) (dimes . 9))) + +;; word math +#| +# Assign equal values to equal letters, and different values to +# different letters, in a way that satisfies the following sum: +# +# TWO +# + TWO +# ----- +# FOUR +|# + + +(define two-four-problem (new problem%)) +(send two-four-problem add-variables '(t w o f u r) (range 10)) +(send two-four-problem add-constraint (new all-different-constraint%)) +(send two-four-problem add-constraint (λ(t w o) (> (word-value t w o) 99)) '(t w o)) +(send two-four-problem add-constraint (λ(f o u r) (> (word-value f o u r) 999)) '(f o u r)) +(send two-four-problem add-constraint + (λ (t w o f u r) + (let ([two (word-value t w o)] + [four (word-value f o u r)]) + ((two . + . two) . = . four))) '(t w o f u r)) +(check-equal? (length (send two-four-problem get-solutions)) 7) +(send two-four-problem add-constraint (λ(r) (= r 0)) '(r)) +(check-hash-items (send two-four-problem get-solution) #hash((o . 5) (w . 6) (u . 3) (f . 1) (r . 0) (t . 7))) + + +;; xsum +#| +# Reorganize the following numbers in a way that each line of +# 5 numbers sum to 27. +# +# 1 6 +# 2 7 +# 3 +# 8 4 +# 9 5 +# +|# + +(define xsum (new problem%)) +(send xsum add-variables '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 10)) +(send xsum add-constraint (λ (l1 l2 l3 l4 x) + (and (< l1 l2 l3 l4) + (= 27 (+ l1 l2 l3 l4 x)))) '(l1 l2 l3 l4 x)) +(send xsum add-constraint (λ (r1 r2 r3 r4 x) + (and (< r1 r2 r3 r4) + (= 27 (+ r1 r2 r3 r4 x)))) '(r1 r2 r3 r4 x)) +(send xsum add-constraint (new all-different-constraint%)) +(check-equal? (length (send xsum get-solutions)) 8) + + + +;; send more money problem +#| +# Assign equal values to equal letters, and different values to +# different letters, in a way that satisfies the following sum: +# +# SEND +# + MORE +# ------ +# MONEY +|# + + +;; queens problem +;; place queens on chessboard so they do not intersect + +(define queens-problem (new problem%)) +(define cols (range 8)) +(define rows (range 8)) +(send queens-problem add-variables cols rows) +(for* ([col1 (in-list cols)] [col2 (in-list cols)] #:when (< col1 col2)) + (send queens-problem add-constraint (λ(row1 row2 [col1 col1][col2 col2]) + (and + ;; test if two cells are on a diagonal + (not (= (abs (- row1 row2)) (abs (- col1 col2)))) + ;; test if two cells are in same row + (not (= row1 row2)))) (list col1 col2))) +(check-equal? (length (send queens-problem get-solutions)) 92) + +(module+ main + (displayln "Tests passed")) \ No newline at end of file diff --git a/csp/variable.rkt b/csp/port/variable.rkt similarity index 100% rename from csp/variable.rkt rename to csp/port/variable.rkt diff --git a/csp/test-problems.rkt b/csp/test-problems.rkt index 203e0cdb..b7c88e61 100644 --- a/csp/test-problems.rkt +++ b/csp/test-problems.rkt @@ -1,75 +1,98 @@ -#lang racket -(require "main.rkt" "test-classes.rkt") -(require rackunit) +#lang at-exp racket +(require "csp.rkt" rackunit) + +(define demo (make-csp)) +(add-vars! demo '(t w) (range 7)) +(add-var! demo 'o '(2 6 7)) + +(define (sum-three t w o) (= 3 (+ t w o))) +(add-constraint! demo sum-three '(t w o)) +(add-pairwise-constraint! demo alldiff= '(t w o)) +(add-pairwise-constraint! demo < '(t w o)) + +(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) (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))))) + +(add-pairwise-constraint! ttf alldiff= '(t w o f u r)) +(add-constraint! ttf (λ (o r) (= (modulo (+ o o) 10) r)) '(o r)) +(add-constraint! ttf (λ (t w o f u r) (= (+ (word-value t w o) (word-value t w o)) + (word-value f o u r))) '(t w o f u r)) +(add-constraint! ttf positive? '(t)) +(add-constraint! ttf positive? '(f)) + +(define ttf-solution (time (solve ttf))) +(check-equal? ttf-solution + ($csp + (list + ($var 't '(7)) + ($var 'w '(3)) + ($var 'o '(4)) + ($var 'f '(1)) + ($var 'u '(6)) + ($var 'r '(8))) + '())) + +(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? (time (solve ttf-solution ttf-print)) "734 + 734 = 1468") ;; ABC problem: ;; what is the minimum value of - ;; ABC ;; ------- ;; A+B+C +(define abc (make-csp)) +(add-vars! abc '(a b c) (range 1 10)) +(define (solution-score sol) + (let ([a ($csp-ref sol 'a)] + [b ($csp-ref sol 'b)] + [c ($csp-ref sol 'c)]) + (/ (+ (* 100 a) (* 10 b) c) (+ a b c)))) -(define abc-problem (new problem%)) -(send abc-problem add-variables '("a" "b" "c") (range 1 10)) -(define (test-solution s) (let ([a (hash-ref s "a")] - [b (hash-ref s "b")] - [c (hash-ref s "c")]) - (/ (+ (* 100 a) (* 10 b) c) (+ a b c)))) -(check-hash-items (argmin test-solution (send abc-problem get-solutions)) - #hash(("c" . 9) ("b" . 9) ("a" . 1))) +(define abc-sols (time (solve* abc))) +(check-equal? (* 9 9 9) (length abc-sols)) +(check-equal? + (argmin solution-score abc-sols) + ($csp (list ($var 'a '(1)) ($var 'b '(9)) ($var 'c '(9))) '())) ;; quarter problem: -;; 26 coins, dollars and quarters +;; 26 dollars and quarters ;; that add up to $17. -(define quarter-problem (new problem%)) -(send quarter-problem add-variables '("dollars" "quarters") (range 1 27)) -(send quarter-problem add-constraint (λ(d q) (= 17 (+ d (* 0.25 q)))) '("dollars" "quarters")) -(send quarter-problem add-constraint (λ(d q) (= 26 (+ d q))) '("dollars" "quarters")) -(check-hash-items (send quarter-problem get-solution) '#hash(("dollars" . 14) ("quarters" . 12))) +(define quarters (make-csp)) +(add-vars! quarters '(dollars quarters) (range 26)) +(add-constraint! quarters (λ (d q) (= 26 (+ d q))) '(dollars quarters)) +(add-constraint! quarters (λ (d q) (= 17 (+ d (* 0.25 q)))) '(dollars quarters)) +(check-equal? (time (solve quarters)) + ($csp (list ($var 'dollars '(14)) ($var 'quarters '(12))) '())) -;; coin problem 2 -#| -A collection of 33 coins, consisting of nickels, dimes, and quarters, has a value of $3.30. If there are three times as many nickels as quarters, and one-half as many dimes as nickels, how many coins of each kind are there? -|# - -(define nickel-problem (new problem%)) -(send nickel-problem add-variables '(nickels dimes quarters) (range 1 34)) -(send nickel-problem add-constraint (λ(n d q) (= 33 (+ n d q))) '(nickels dimes quarters)) -(send nickel-problem add-constraint (λ(n d q) (= 3.30 (+ (* 0.05 n) (* 0.1 d) (* 0.25 q)))) '(nickels dimes quarters)) -(send nickel-problem add-constraint (λ(n q) (= n (* 3 q))) '(nickels quarters)) -(send nickel-problem add-constraint (λ(d n) (= n (* 2 d))) '(dimes nickels)) -(check-hash-items (send nickel-problem get-solution) #hash((nickels . 18) (quarters . 6) (dimes . 9))) -;; word math +;; nickel problem #| -# Assign equal values to equal letters, and different values to -# different letters, in a way that satisfies the following sum: -# -# TWO -# + TWO -# ----- -# FOUR +A collection of 33 coins, consisting of nickels, dimes, and quarters, has a value of $3.30. If there are three times as many nickels as quarters, and one-half as many dimes as nickels, how many coins of each kind are there? |# - - -(define two-four-problem (new problem%)) -(send two-four-problem add-variables '(t w o f u r) (range 10)) -(send two-four-problem add-constraint (new all-different-constraint%)) -(send two-four-problem add-constraint (λ(t w o) (> (word-value t w o) 99)) '(t w o)) -(send two-four-problem add-constraint (λ(f o u r) (> (word-value f o u r) 999)) '(f o u r)) -(send two-four-problem add-constraint - (λ (t w o f u r) - (let ([two (word-value t w o)] - [four (word-value f o u r)]) - ((two . + . two) . = . four))) '(t w o f u r)) -(check-equal? (length (send two-four-problem get-solutions)) 7) -(send two-four-problem add-constraint (λ(r) (= r 0)) '(r)) -(check-hash-items (send two-four-problem get-solution) #hash((o . 5) (w . 6) (u . 3) (f . 1) (r . 0) (t . 7))) +(define nickels (make-csp)) +(add-vars! nickels '(n d q) (range 33)) +(add-constraint! nickels (λ (n d q) (= 33 (+ n d q))) '(n d q) 'count-33) +(add-constraint! nickels (λ (n d q) (= 330 (+ (* n 5) (* d 10) (* q 25)))) '(n d q) 'total-3.30) +(add-constraint! nickels (λ (n q) (= (* 3 q) n)) '(n q) 'triple-nickel) +(add-constraint! nickels (λ (d n) (= (* 2 d) n)) '(d n) 'double-nickel) +(check-equal? (time (solve nickels)) + ($csp (list ($var 'n '(18)) ($var 'd '(9)) ($var 'q '(6))) '())) ;; xsum @@ -85,17 +108,15 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu # |# -(define xsum-problem (new problem%)) -(send xsum-problem add-variables '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 10)) -(send xsum-problem add-constraint (λ (l1 l2 l3 l4 x) - (and (< l1 l2 l3 l4) - (= 27 (+ l1 l2 l3 l4 x)))) '(l1 l2 l3 l4 x)) -(send xsum-problem add-constraint (λ (r1 r2 r3 r4 x) - (and (< r1 r2 r3 r4) - (= 27 (+ r1 r2 r3 r4 x)))) '(r1 r2 r3 r4 x)) -(send xsum-problem add-constraint (new all-different-constraint%)) -(check-equal? (length (send xsum-problem get-solutions)) 8) +(define xsum (make-csp)) +(add-vars! xsum '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 1 10)) +(add-pairwise-constraint! xsum < '(l1 l2 l3 l4)) +(add-pairwise-constraint! xsum < '(r1 r2 r3 r4)) +(add-constraint! xsum (λ (l1 l2 l3 l4 x) (= 27 (+ l1 l2 l3 l4 x))) '(l1 l2 l3 l4 x)) +(add-constraint! xsum (λ (r1 r2 r3 r4 x) (= 27 (+ r1 r2 r3 r4 x))) '(r1 r2 r3 r4 x)) +(add-pairwise-constraint! xsum alldiff= '(l1 l2 l3 l4 r1 r2 r3 r4 x)) +(check-equal? (length (time (solve* xsum))) 8) ;; send more money problem @@ -109,40 +130,39 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu # MONEY |# -(define sm-problem (new problem%)) -(send sm-problem add-variables '(s e n d m o r y) (range 10)) -(send sm-problem add-constraint (λ(x) (> x 0)) '(s)) -(send sm-problem add-constraint (λ(x) (> x 0)) '(m)) -(send sm-problem add-constraint (λ(d e y) (= (modulo (+ d e) 10) y)) '(d e y)) -(send sm-problem add-constraint (λ(n d r e y) - (= (modulo (+ (word-value n d) (word-value r e)) 100) - (word-value e y))) '(n d r e y)) -(send sm-problem add-constraint (λ(e n d o r y) - (= (modulo (+ (word-value e n d) (word-value o r e)) 1000) (word-value n e y))) '(e n d o r y)) -(send sm-problem add-constraint (λ(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)) -(send sm-problem add-constraint (new all-different-constraint%)) - -(check-hash-items (send sm-problem get-solution) '#hash((m . 1) (e . 5) (r . 8) (n . 6) (y . 2) (o . 0) (d . 7) (s . 9))) - +(define smm (make-csp)) +(add-vars! smm '(s e n d m o r y) (λ () (reverse (range 10)))) +(add-constraint! smm positive? '(s)) +(add-constraint! smm positive? '(m)) +(add-constraint! smm (λ (d e y) (= (modulo (+ d e) 10) y)) '(d e y)) +(add-constraint! smm (λ (n d r e y) + (= (modulo (+ (word-value n d) (word-value r e)) 100) + (word-value e y))) '(n d r e y)) +(add-constraint! smm (λ (e n d o r y) + (= (modulo (+ (word-value e n d) (word-value o r e)) 1000) (word-value n e y))) '(e n d o r y)) +(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)) +(add-pairwise-constraint! smm alldiff= '(s e n d m o r y)) + +;; todo: too slow +;(solve smm) ;; queens problem ;; place queens on chessboard so they do not intersect - -(define queens-problem (new problem%)) -(define cols (range 8)) -(define rows (range 8)) -(send queens-problem add-variables cols rows) -(for* ([col1 (in-list cols)] [col2 (in-list cols)] #:when (< col1 col2)) - (send queens-problem add-constraint (λ(row1 row2 [col1 col1][col2 col2]) - (and - ;; test if two cells are on a diagonal - (not (= (abs (- row1 row2)) (abs (- col1 col2)))) - ;; test if two cells are in same row - (not (= row1 row2)))) (list col1 col2))) -(check-equal? (length (send queens-problem get-solutions)) 92) - -(module+ main - (displayln "Tests passed")) \ No newline at end of file +(define queens (make-csp)) +(define qs (for/list ([q 8]) (string->symbol (format "q~a" q)))) +(define rows (range (length qs))) +(add-vars! queens qs rows) +(define (q-col q) (string->number (string-trim (symbol->string q) "q"))) +(for* ([qs (in-combinations qs 2)]) + (match-define (list qa qb) qs) + (match-define (list qa-col qb-col) (map q-col qs)) + (add-constraint! queens + (λ (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 (time (solve* queens)))) \ No newline at end of file diff --git a/csp/test.rkt b/csp/test.rkt index f3fa6b26..c287d30d 100644 --- a/csp/test.rkt +++ b/csp/test.rkt @@ -1,169 +1,21 @@ #lang at-exp racket (require "csp.rkt" rackunit) -(define demo (make-csp)) -(add-vars! demo '(t w) (range 7)) -(add-var! demo 'o '(2 6 7)) - -(define (sum-three t w o) (= 3 (+ t w o))) -(add-constraint! demo sum-three '(t w o)) -(add-pairwise-constraint! demo alldiff= '(t w o)) -(add-pairwise-constraint! demo < '(t w o)) - -(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) (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))))) - -(add-pairwise-constraint! ttf alldiff= '(t w o f u r)) -(add-constraint! ttf (λ (o r) (= (modulo (+ o o) 10) r)) '(o r)) -(add-constraint! ttf (λ (t w o f u r) (= (+ (word-value t w o) (word-value t w o)) - (word-value f o u r))) '(t w o f u r)) -(add-constraint! ttf positive? '(t)) -(add-constraint! ttf positive? '(f)) - -(define ttf-solution (time (solve ttf))) -(check-equal? ttf-solution - ($csp - (list - ($var 't '(7)) - ($var 'w '(3)) - ($var 'o '(4)) - ($var 'f '(1)) - ($var 'u '(6)) - ($var 'r '(8))) - '())) - -(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? (time (solve ttf-solution ttf-print)) "734 + 734 = 1468") - - -;; ABC problem: -;; what is the minimum value of -;; ABC -;; ------- -;; A+B+C - -(define abc (make-csp)) -(add-vars! abc '(a b c) (range 1 10)) -(define (solution-score sol) - (let ([a ($csp-ref sol 'a)] - [b ($csp-ref sol 'b)] - [c ($csp-ref sol 'c)]) - (/ (+ (* 100 a) (* 10 b) c) (+ a b c)))) - - -(define abc-sols (time (solve* abc))) -(check-equal? (* 9 9 9) (length abc-sols)) -(check-equal? - (argmin solution-score abc-sols) - ($csp (list ($var 'a '(1)) ($var 'b '(9)) ($var 'c '(9))) '())) - - -;; quarter problem: -;; 26 dollars and quarters -;; that add up to $17. - -(define quarters (make-csp)) -(add-vars! quarters '(dollars quarters) (range 26)) -(add-constraint! quarters (λ (d q) (= 26 (+ d q))) '(dollars quarters)) -(add-constraint! quarters (λ (d q) (= 17 (+ d (* 0.25 q)))) '(dollars quarters)) -(check-equal? (time (solve quarters)) - ($csp (list ($var 'dollars '(14)) ($var 'quarters '(12))) '())) - - -;; nickel problem -#| -A collection of 33 coins, consisting of nickels, dimes, and quarters, has a value of $3.30. If there are three times as many nickels as quarters, and one-half as many dimes as nickels, how many coins of each kind are there? -|# -(define nickels (make-csp)) -(add-vars! nickels '(n d q) (range 33)) -(add-constraint! nickels (λ (n d q) (= 33 (+ n d q))) '(n d q) 'count-33) -(add-constraint! nickels (λ (n d q) (= 330 (+ (* n 5) (* d 10) (* q 25)))) '(n d q) 'total-3.30) -(add-constraint! nickels (λ (n q) (= (* 3 q) n)) '(n q) 'triple-nickel) -(add-constraint! nickels (λ (d n) (= (* 2 d) n)) '(d n) 'double-nickel) -(check-equal? (time (solve nickels)) - ($csp (list ($var 'n '(18)) ($var 'd '(9)) ($var 'q '(6))) '())) - - -;; xsum #| -# Reorganize the following numbers in a way that each line of -# 5 numbers sum to 27. -# -# 1 6 -# 2 7 -# 3 -# 8 4 -# 9 5 -# +(define creduce (assign-val ($csp (list ($var 'a '(1 2 3)) ($var 'b '(2 3)) ($var 'c '(1 2 3 4 5))) (list ($constraint '(a b c) (procedure-rename (λ (a b c) (= (+ a b c) 4)) 'summer)))) 'a 1)) +(check-equal? + (make-arcs-consistent (reduce-constraint-arity creduce)) + ($csp (list ($var 'a '(1)) ($var 'b '(2)) ($var 'c '(1))) '())) + +(define f (λ (a b c d) (+ a b c d))) +(check-equal? 10 ((reduce-arity f '(1 b c d)) 2 3 4)) +(check-equal? 10 ((reduce-arity f '(1 2 c d)) 3 4)) +(check-equal? 10 ((reduce-arity f '(1 2 3 d)) 4)) +(check-equal? 10 ((reduce-arity f '(1 b 3 d)) 2 4)) +(check-equal? 10 ((reduce-arity f '(a b 3 d)) 1 2 4)) |# -(define xsum (make-csp)) -(add-vars! xsum '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 1 10)) -(add-pairwise-constraint! xsum < '(l1 l2 l3 l4)) -(add-pairwise-constraint! xsum < '(r1 r2 r3 r4)) -(add-constraint! xsum (λ (l1 l2 l3 l4 x) (= 27 (+ l1 l2 l3 l4 x))) '(l1 l2 l3 l4 x)) -(add-constraint! xsum (λ (r1 r2 r3 r4 x) (= 27 (+ r1 r2 r3 r4 x))) '(r1 r2 r3 r4 x)) -(add-pairwise-constraint! xsum alldiff= '(l1 l2 l3 l4 r1 r2 r3 r4 x)) - -(check-equal? (length (time (solve* xsum))) 8) - - -;; send more money problem -#| -# Assign equal values to equal letters, and different values to -# different letters, in a way that satisfies the following sum: -# -# SEND -# + MORE -# ------ -# MONEY -|# - -(define smm (make-csp)) -(add-vars! smm '(s e n d m o r y) (range 10)) -(add-constraint! smm positive? '(s)) -(add-constraint! smm positive? '(m)) -(add-constraint! smm (λ (d e y) (= (modulo (+ d e) 10) y)) '(d e y)) -(add-constraint! smm (λ (n d r e y) - (= (modulo (+ (word-value n d) (word-value r e)) 100) - (word-value e y))) '(n d r e y)) -(add-constraint! smm (λ (e n d o r y) - (= (modulo (+ (word-value e n d) (word-value o r e)) 1000) (word-value n e y))) '(e n d o r y)) -(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)) -(add-pairwise-constraint! smm alldiff= '(s e n d m o r y)) - -;; todo: too slow -;(solve smm) - -;; queens problem -;; place queens on chessboard so they do not intersect -(define queens (make-csp)) -(define qs (for/list ([q 8]) (string->symbol (format "q~a" q)))) -(define rows (range (length qs))) -(add-vars! queens qs rows) -(define (q-col q) (string->number (string-trim (symbol->string q) "q"))) -(for* ([qs (in-combinations qs 2)]) - (match-define (list qa qb) qs) - (match-define (list qa-col qb-col) (map q-col qs)) - (add-constraint! queens - (λ (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))) +(make-nodes-consistent ($csp (list ($var 'a '(1)) ($var 'b '(0 1))) (list ($constraint '(b) zero?)))) -(check-equal? 92 (length (time (solve* queens)))) +(remove-assigned-constraints ($csp (list ($var 'a '(1)) ($var 'b '(0 1))) (list ($constraint '(b) zero?))))