From e61783961d861fc4fa9420439ab5a524568fab3f Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Sat, 13 Oct 2018 19:37:19 -0700
Subject: [PATCH] changes

---
 csp/csp.rkt                      | 136 +++++++++-----------
 csp/main.rkt                     |  13 +-
 csp/{ => port}/constraint.rkt    |   0
 csp/{ => port}/domain.rkt        |   0
 csp/{ => port}/helper.rkt        |   0
 csp/port/main.rkt                |  13 ++
 csp/{ => port}/problem.rkt       |   0
 csp/{ => port}/solver.rkt        |   0
 csp/{ => port}/test-classes.rkt  |   0
 csp/{ => port}/test-einstein.rkt |   0
 csp/port/test-problems.rkt       | 130 +++++++++++++++++++
 csp/{ => port}/variable.rkt      |   0
 csp/test-problems.rkt            | 214 +++++++++++++++++--------------
 csp/test.rkt                     | 174 ++-----------------------
 14 files changed, 338 insertions(+), 342 deletions(-)
 rename csp/{ => port}/constraint.rkt (100%)
 rename csp/{ => port}/domain.rkt (100%)
 rename csp/{ => port}/helper.rkt (100%)
 create mode 100644 csp/port/main.rkt
 rename csp/{ => port}/problem.rkt (100%)
 rename csp/{ => port}/solver.rkt (100%)
 rename csp/{ => port}/test-classes.rkt (100%)
 rename csp/{ => port}/test-einstein.rkt (100%)
 create mode 100644 csp/port/test-problems.rkt
 rename csp/{ => port}/variable.rkt (100%)

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