progress

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))
+(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))

csp/domain.rkt

@@ -60,4 +60,5 @@
     
     
     ))
-(define Domain? (is-a?/c Domain))
+(define Domain? (is-a?/c Domain))
+

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.

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

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))
+(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)))
+
+

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