diff --git a/csp/constraint.rkt b/csp/constraint.rkt index 1dfb73c6..1f072654 100644 --- a/csp/constraint.rkt +++ b/csp/constraint.rkt @@ -2,6 +2,7 @@ (require racket/class sugar/container "helper.rkt" "variable.rkt") (provide (all-defined-out)) + (define Constraint (class object% (super-new) @@ -132,4 +133,42 @@ (return-k)) return-value))) -(define AllDifferentConstraint? (is-a?/c AllDifferentConstraint)) \ No newline at end of file +(define AllDifferentConstraint? (is-a?/c AllDifferentConstraint)) + + +(define AllEqualConstraint + ;; 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 singlevalue _unassigned) + (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)) + (cond + [(equal? singlevalue _unassigned) (set! singlevalue value)] + [(and (not (equal? value _unassigned)) (not (equal? value singlevalue))) + (set! return-value #f) + (return-k)])) + (when (and forwardcheck (not (equal? singlevalue _unassigned))) + (for ([variable (in-list variables)]) + (when (not (variable . in? . assignments)) + (set! domain (hash-ref domains variable)) + (when (not (singlevalue . in? . (get-field _list domain))) + (set! return-value #f) + (return-k)) + (for ([value (in-list (get-field _list domain))]) + (when (not (equal? value singlevalue)) + (send domain hideValue value)))))) + (set! return-value #t) + (return-k)) + return-value))) + +(define AllEqualConstraint? (is-a?/c AllEqualConstraint)) diff --git a/csp/domain.rkt b/csp/domain.rkt index 39a66bfa..6ba0b1f0 100644 --- a/csp/domain.rkt +++ b/csp/domain.rkt @@ -60,4 +60,5 @@ )) -(define Domain? (is-a?/c Domain)) \ No newline at end of file +(define Domain? (is-a?/c Domain)) + diff --git a/csp/helper.rkt b/csp/helper.rkt index 820cff34..ffb993ce 100644 --- a/csp/helper.rkt +++ b/csp/helper.rkt @@ -1,8 +1,11 @@ #lang racket/base (require racket/list) (provide (all-defined-out)) +(require rackunit) -(module+ test (require rackunit)) +(define-simple-check (check-hash-items h1 h2) + (for/and ([(k1 v1) (in-hash h1)]) + (equal? (hash-ref h2 k1) v1))) (define (list-comparator xs ys) ;; For use in sort. Compares two lists element by element. diff --git a/csp/problem.rkt b/csp/problem.rkt index 373bf28e..8b8de27a 100644 --- a/csp/problem.rkt +++ b/csp/problem.rkt @@ -6,11 +6,10 @@ ;; Class used to define a problem and retrieve solutions (class/c [reset (->m void?)] - ;; todo: tighten `object?` contracts [setSolver (Solver? . ->m . void?)] [getSolver (->m Solver?)] ;; todo: tighten `object?` contract - [addVariable (any/c (or/c list? object?) . ->m . void?)] + [addVariable (any/c (or/c list? Domain?) . ->m . void?)] [getSolutions (->m list?)]) (class* object% (printable<%>) (super-new) @@ -45,8 +44,7 @@ (error 'addVariable (format "Tried to insert duplicated variable ~a" variable))) (cond [(list? domain) (set! domain (new Domain [set domain]))] - ;; todo: test for `instance-of-Domain?` ; how to copy domain? - [(object? domain) (set! domain '(copy.copy domain))] + [(Domain? domain) (set! domain (send domain copy))] [else (error 'addVariable "Domains must be instances of subclasses of Domain")]) (when (not (object? domain)) (error 'fudge)) (when (not domain) ; todo: check this test diff --git a/csp/test-classes.rkt b/csp/test-classes.rkt index a940df43..086f2bdc 100644 --- a/csp/test-classes.rkt +++ b/csp/test-classes.rkt @@ -13,4 +13,34 @@ (check-equal? (get-field _variables problem) (make-hash)) (send problem addVariables '("a" "b") '(1 2 3)) (check-equal? (get-field _list (hash-ref (get-field _variables problem) "a")) '(1 2 3)) -(check-equal? (get-field _list (hash-ref (get-field _variables problem) "b")) '(1 2 3)) \ No newline at end of file +(check-equal? (get-field _list (hash-ref (get-field _variables problem) "b")) '(1 2 3)) + + +;; FunctionConstraint, two ways: implicit and explicit +(send problem reset) +(send problem addVariables '(a b) '(1 2)) +(send problem addConstraint >) ; implicit +(check-hash-items (send problem getSolution) #hash((a . 1) (b . 2))) +(send problem reset) +(send problem addVariables '(a b) '(1 2)) +(send problem addConstraint (new FunctionConstraint [func >])) ; explicit +(check-hash-items (send problem getSolution) #hash((a . 1) (b . 2))) + +;; AllDifferentConstraint +(send problem reset) +(send problem addVariables '(a b) '(1 2)) +(send problem addConstraint (new AllDifferentConstraint)) +(let ([solutions (send problem getSolutions)]) + (check-equal? (hash-ref (first solutions) 'a) (hash-ref (second solutions) 'b)) + (check-equal? (hash-ref (second solutions) 'a) (hash-ref (first solutions) 'b))) + + +;; AllEqualConstraint +(send problem reset) +(send problem addVariables '(a b) '(1 2)) +(send problem addConstraint (new AllEqualConstraint)) +(let ([solutions (send problem getSolutions)]) + (check-equal? (hash-ref (first solutions) 'a) (hash-ref (first solutions) 'b)) + (check-equal? (hash-ref (second solutions) 'a) (hash-ref (second solutions) 'b))) + + diff --git a/csp/test-problems.rkt b/csp/test-problems.rkt index c2b85cf0..976b9d93 100644 --- a/csp/test-problems.rkt +++ b/csp/test-problems.rkt @@ -2,9 +2,6 @@ (require "main.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