diff --git a/csp/constraint-tests.rkt b/csp/constraint-tests.rkt new file mode 100644 index 00000000..f552d0b5 --- /dev/null +++ b/csp/constraint-tests.rkt @@ -0,0 +1,146 @@ +#lang racket +(require "constraint.rkt") +(require rackunit) + +(define-simple-check (check-hash-items h1 h2) + (for/and ([(k1 v1) (in-hash h1)]) + (equal? (hash-ref h2 k1) v1))) + +;; ABC problem: +;; what is the minimum value of + +;; ABC +;; ------- +;; A+B+C + + +(define abc-problem (new Problem)) +(send abc-problem addVariables '("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 getSolutions)) + #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 addVariables '("dollars" "quarters") (range 1 27)) +(send quarter-problem addConstraint (λ(d q) (= 17 (+ d (* 0.25 q)))) '("dollars" "quarters")) +(send quarter-problem addConstraint (λ(d q) (= 26 (+ d q))) '("dollars" "quarters")) +(check-hash-items (send quarter-problem getSolution) '#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 addVariables '(nickels dimes quarters) (range 1 34)) +(send nickel-problem addConstraint (λ(n d q) (= 33 (+ n d q))) '(nickels dimes quarters)) +(send nickel-problem addConstraint (λ(n d q) (= 3.30 (+ (* 0.05 n) (* 0.1 d) (* 0.25 q)))) '(nickels dimes quarters)) +(send nickel-problem addConstraint (λ(n q) (= n (* 3 q))) '(nickels quarters)) +(send nickel-problem addConstraint (λ(d n) (= n (* 2 d))) '(dimes nickels)) +(check-hash-items (send nickel-problem getSolution) #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 addVariables '(t w o f u r) (range 10)) +(send two-four-problem addConstraint (new AllDifferentConstraint)) +(send two-four-problem addConstraint (λ(t w o) (> (word-value t w o) 99)) '(t w o)) +(send two-four-problem addConstraint (λ(f o u r) (> (word-value f o u r) 999)) '(f o u r)) +(send two-four-problem addConstraint + (λ (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 getSolutions)) 7) +(send two-four-problem addConstraint (λ(r) (= r 0)) '(r)) +(check-hash-items (send two-four-problem getSolution) #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-problem (new Problem)) +(send xsum-problem addVariables '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 10)) +(send xsum-problem addConstraint (λ (l1 l2 l3 l4 x) + (and (< l1 l2 l3 l4) + (= 27 (+ l1 l2 l3 l4 x)))) '(l1 l2 l3 l4 x)) +(send xsum-problem addConstraint (λ (r1 r2 r3 r4 x) + (and (< r1 r2 r3 r4) + (= 27 (+ r1 r2 r3 r4 x)))) '(r1 r2 r3 r4 x)) +(send xsum-problem addConstraint (new AllDifferentConstraint)) +(check-equal? (length (send xsum-problem getSolutions)) 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 sm-problem (new Problem)) +(send sm-problem addVariables '(s e n d m o r y) (range 10)) +(send sm-problem addConstraint (λ(x) (> x 0)) '(s)) +(send sm-problem addConstraint (λ(x) (> x 0)) '(m)) +(send sm-problem addConstraint (λ(d e y) (= (modulo (+ d e) 10) y)) '(d e y)) +(send sm-problem addConstraint (λ(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 addConstraint (λ(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 addConstraint (λ(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 addConstraint (new AllDifferentConstraint)) + +(check-hash-items (send sm-problem getSolution) '#hash((m . 1) (e . 5) (r . 8) (n . 6) (y . 2) (o . 0) (d . 7) (s . 9))) + + +;; queens problem +(define qp (new Problem)) +(define cols (range 8)) +(define rows (range 8)) +(send qp addVariables cols rows) +(for* ([col1 (in-list cols)] [col2 (in-list cols)] #:when (< col1 col2)) + (send qp addConstraint (λ(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 qp getSolutions)) 92) \ No newline at end of file diff --git a/csp/constraint.rkt b/csp/constraint.rkt index 76807042..d13c06ee 100644 --- a/csp/constraint.rkt +++ b/csp/constraint.rkt @@ -31,7 +31,7 @@ # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |# -(provide (all-defined-out)) +(provide (all-defined-out) (all-from-out "helpers.rkt")) ;(provide Problem Variable Domain Unassigned Solver BacktrackingSolver RecursiveBacktrackingSolver MinConflictsSolver Constraint FunctionConstraint AllDifferentConstraint AllEqualConstraint MaxSumConstraint ExactSumConstraint MinSumConstraint InSetConstraint NotInSetConstraint SomeInSetConstraint SomeNotInSetConstraint) ;(define Problem/c (λ(x) (is-a x Problem))) @@ -89,7 +89,11 @@ (define/public (addVariables variables domain) ;; Add one or more variables to the problem - (for-each (λ(var) (addVariable var domain)) variables)) + (define listified-variables + (cond + [(string? variables) (map (λ(c) (format "~a" c)) (string->list variables))] + [else variables])) + (for-each (λ(var) (addVariable var domain)) listified-variables)) (define/public (addConstraint constraint [variables null]) ;; Add a constraint to the problem @@ -98,7 +102,7 @@ (if (procedure? constraint) (set! constraint (new FunctionConstraint [func constraint])) (error 'addConstraint "Constraints must be instances of class Constraint"))) - (py-append! _constraints (cons constraint variables))) + (py-append! _constraints (list constraint variables))) (define/public (getSolution) ;; Find and return a solution to the problem @@ -119,19 +123,19 @@ (define allvariables (hash-keys domains)) (define constraints null) (for ([constraint-variables-pair (in-list _constraints)]) - (match-define (cons constraint variables) constraint-variables-pair) - (when (not variables) + (match-define (list constraint variables) constraint-variables-pair) + (when (null? variables) (set! variables allvariables)) - (set! constraints (append constraints (list (cons constraint variables))))) + (set! constraints (append constraints (list (list constraint variables))))) (define vconstraints (make-hash)) (for ([variable (in-hash-keys domains)]) (hash-set! vconstraints variable null)) (for ([constraint-variables-pair (in-list constraints)]) - (match-define (cons constraint variables) constraint-variables-pair) + (match-define (list constraint variables) constraint-variables-pair) (for ([variable (in-list variables)]) - (hash-update! vconstraints variable (λ(val) (append val (list (cons constraint variables))))))) + (hash-update! vconstraints variable (λ(val) (append val (list (list constraint variables))))))) (for ([constraint-variables-pair (in-list constraints)]) - (match-define (cons constraint variables) constraint-variables-pair) + (match-define (list constraint variables) constraint-variables-pair) (send constraint preProcess variables domains constraints vconstraints)) (define result #f) (let/ec done @@ -257,11 +261,13 @@ (when (= (length variables) 1) (define variable (list-ref variables 0)) (define domain (hash-ref domains variable)) - (for ([value (in-list domain)]) + (for ([value (in-list (get-field _list domain))]) + (when (not (call variables domains (make-hash (list (cons variable value))))) - (set! domain (remove value domain)))) - (set! constraints (remove (cons this variables) constraints)) - (hash-remove! vconstraints variable (cons this variables)))) + (set-field! _list domain (remove value (get-field _list domain))))) + + (set! constraints (remove (list this variables) constraints)) + (hash-update! vconstraints variable (λ(val) (remove (list this variables) val))))) (define/public (forwardCheck variables domains assignments [_unassigned Unassigned]) ;; Helper method for generic forward checking @@ -303,7 +309,7 @@ (field [_func func][_assigned assigned]) (inherit forwardCheck) - (define/override (call variables domains assignments [forwardcheck #f] [_unassigned Unassigned])1 + (define/override (call variables domains assignments [forwardcheck #f] [_unassigned Unassigned]) ;(report assignments assignments-before) (define parms (for/list ([x (in-list variables)]) (if (hash-has-key? assignments x) (hash-ref assignments x) _unassigned))) @@ -325,6 +331,42 @@ )) (define FunctionConstraint? (is-a?/c FunctionConstraint)) +(define AllDifferentConstraint + ;; Constraint enforcing that values of all given variables are different + + (class Constraint + (super-new) + + (define/override (call variables domains assignments [forwardcheck #f] [_unassigned Unassigned]) + (define seen (make-hash)) + (define value #f) + (define domain #f) + (define return-value (void)) + (let/ec return-k + (for ([variable (in-list variables)]) + (set! value (if (hash-has-key? assignments variable) + (hash-ref assignments variable) + _unassigned)) + (when (not (equal? value _unassigned)) + (when (value . in? . seen) + (set! return-value #f) + (return-k)) + (hash-set! seen value #t))) + (when forwardcheck + (for ([variable (in-list variables)]) + (when (not (variable . in? . assignments)) + (set! domain (hash-ref domains variable)) + (for ([value (in-hash-keys seen)]) + (when (value . in? . (get-field _list (hash-ref domains variable))) + (send domain hideValue value) + (when (null? (get-field _list (hash-ref domains variable))) + (set! return-value #f) + (return-k))))))) + (set! return-value #t) + (return-k)) + return-value))) + +(define AllDifferentConstraint? (is-a?/c AllDifferentConstraint)) ;; ---------------------------------------------------------------------- ;; Variables @@ -365,6 +407,9 @@ (field [_forwardcheck forwardcheck]) (define/override (getSolutionIter domains constraints vconstraints) + + + (define forwardcheck _forwardcheck) (define assignments (make-hash)) (define queue null) @@ -458,7 +503,7 @@ (let/ec break-for-loop (for ([cvpair (in-list (hash-ref vconstraints variable))]) - (match-define (cons constraint variables) cvpair) + (match-define (list constraint variables) cvpair) (define the_result (send constraint call variables domains assignments pushdomains)) ;(report pushdomains pushdomains2) ;(report domains domains2) @@ -489,7 +534,7 @@ solution)) (define/override (getSolution . args) - (apply call-solution-generator #:first-only #t args)) + (car (apply call-solution-generator #:first-only #t args))) (define/override (getSolutions . args) (apply call-solution-generator args)) @@ -497,17 +542,6 @@ )) -(module+ main - (define problem (new Problem)) - (send problem addVariables '("a" "b" "c") (range 1 10)) -; (send problem addConstraint (λ(a b) (and (> a 0) (= b (* 211 a)))) '("a" "b")) - - (displayln (format "The solution to ~a is ~a" - problem - (argmin (λ(h) - (let ([a (hash-ref h "a")] - [b (hash-ref h "b")] - [c (hash-ref h "c")]) - (/ (+ (* 100 a) (* 10 b) c) (+ a b c)))) - (send problem getSolutions))))) - \ No newline at end of file + + + diff --git a/csp/helpers.rkt b/csp/helpers.rkt index e845fe10..820cff34 100644 --- a/csp/helpers.rkt +++ b/csp/helpers.rkt @@ -14,6 +14,7 @@ (cond [(equal? x y) (list-comparator (cdr xs) (cdr ys))] [(and (real? x) (real? y)) (< x y)] + [(and (symbol? x) (symbol? y)) (apply stringstring (list x y)))] [(and (string? x) (string? y)) (string 0 and b == 211 * a -problem.addConstraint(func, ["a", "b"]) -print problem.getSolutions() +problem.addVariables(["a", "b"], [1, 2]) +problem.addConstraint(AllDifferentConstraint()) +print problem.getSolutions() \ No newline at end of file diff --git a/csp/python-constraint/trials/queens.py b/csp/python-constraint/trials/queens.py index deac7131..73ec4569 100755 --- a/csp/python-constraint/trials/queens.py +++ b/csp/python-constraint/trials/queens.py @@ -7,7 +7,7 @@ import sys def main(show=False): problem = Problem() - size = 8 + size = 12 cols = range(size) rows = range(size) problem.addVariables(cols, rows)