progress

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)

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

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 string<? (map symbol->string (list x y)))] 
               [(and (string? x) (string? y)) (string<? x y)]
               [else (error 'list-comparator (format "Can’t compare ~v and ~v" x y))]))]))
 
@@ -22,7 +23,8 @@
   (check-false (list-comparator (range 2) (range 2)))
   (check-true (list-comparator (range 2) (range 4)))
   (check-false (list-comparator (range 4) (range 2)))
-  (check-true (list-comparator '(1 1 "a") '(1 1 "b"))))
+  (check-true (list-comparator '(1 1 "a") '(1 1 "b")))
+  (check-true (list-comparator '(1 1 a) '(1 1 b))))
 
 (define-syntax-rule (py-pop! xs)
   (let ([i (last xs)])
@@ -46,4 +48,10 @@
     (check-equal? xs '(1 2 3 (0 1))))
   (let ([xs '(1 2 3)])
     (py-extend! xs (range 2))
-    (check-equal? xs '(1 2 3 0 1))))
+    (check-equal? xs '(1 2 3 0 1))))
+
+
+(define (word-value . xs)
+  (let ([xs (reverse xs)])
+    (for/sum ([i (in-range (length xs))])
+      (* (list-ref xs i) (expt 10 i)))))

csp/python-constraint/constraint.py

@@ -191,6 +191,7 @@ class Problem(object):
                           the order may be important.
         @type  variables: set or sequence of variables
         """
+        print "self._constraints", self._constraints
         if not isinstance(constraint, Constraint):
             if callable(constraint):
                 constraint = FunctionConstraint(constraint)
@@ -198,6 +199,7 @@ class Problem(object):
                 raise ValueError, "Constraints must be instances of "\
                                   "subclasses of the Constraint class"
         self._constraints.append((constraint, variables))
+        print "self._constraints", self._constraints
 
     def getSolution(self):
         """
@@ -455,6 +457,7 @@ class BacktrackingSolver(Solver):
 
         queue = []
 
+
         while True:
             #print "starting while loop 1"
 
@@ -595,6 +598,7 @@ class RecursiveBacktrackingSolver(Solver):
     def recursiveBacktracking(self, solutions, domains, vconstraints,
                               assignments, single):
 
+
         # Mix the Degree and Minimum Remaing Values (MRV) heuristics
         lst = [(-len(vconstraints[variable]),
                 len(domains[variable]), variable) for variable in domains]
@@ -602,7 +606,7 @@ class RecursiveBacktrackingSolver(Solver):
         for item in lst:
             if item[-1] not in assignments:
                 # Found an unassigned variable. Let's go.
-                break
+                breakit
         else:
             # No unassigned variables. We've got a solution.
             solutions.append(assignments.copy())

csp/python-constraint/testconstraint.py

@@ -8,8 +8,6 @@ from constraint import *
 #print p.getSolutions()
 
 problem = Problem()
-problem.addVariables(["a", "b"], range(500))
-def func(a, b):
-    return a > 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()

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)