simplify

csp/csp.rkt

@@ -19,8 +19,8 @@
       [else
        (match-define (cons name other-names) names)
        (for/and ([val (in-list ($csp-vals csp name))])
-         ;; todo: reconsider efficiency of currying every value
-         (($constraint other-names (curry proc val)) csp))])))
+                ;; todo: reconsider efficiency of currying every value
+                (($constraint other-names (curry proc val)) csp))])))
 
 (define/contract (check-name-in-csp! caller csp name)
   (symbol? $csp? $var-name? . -> . void?)
@@ -28,8 +28,7 @@
   (unless (memq name names)
     (raise-argument-error caller (format "csp variable name: ~v" names) name)))
 
-(define/contract (nary-constraint? constraint n)
-  ($constraint? exact-nonnegative-integer? . -> . boolean?)
+(define (nary-constraint? constraint n)
   (= n (length ($constraint-names constraint))))
 
 (define/contract (unary-constraint? constraint)
@@ -40,31 +39,33 @@
   ($constraint? . -> . boolean?)
   (nary-constraint? constraint 2))
 
-(define/contract (add-var! csp name [vals empty])
-  (($csp? $var-name?) ((listof any/c)) . ->* . void?)
-  (add-vars! csp (list name) vals))
-
-(define/contract (add-vars! csp names [vals empty])
-  (($csp? (listof $var-name?)) ((listof any/c)) . ->* . void?)
-  (for ([name (in-list names)]
-        #:when (memq name (map $var-name ($csp-vars csp))))
-    (raise-argument-error 'add-var! "var that doesn't exist" name))
-  (for ([name (in-list names)])
-    (set-$csp-vars! csp (cons ($var name vals) ($csp-vars csp)))))
-
-(define (unique-varnames? xs)
-  (and (andmap $var-name? xs) (not (check-duplicates xs eq?))))
+(define/contract (add-vars! csp names [vals-or-procedure empty])
+  (($csp? (listof $var-name?)) ((or/c (listof any/c) procedure?)) . ->* . void?)
+  (for/fold ([vars ($csp-vars csp)]
+             #:result (set-$csp-vars! csp vars))
+            ([name (in-list names)])
+    (when (memq name (map $var-name vars))
+      (raise-argument-error 'add-vars! "var that doesn't exist" name))
+    (append vars
+            (let ([vals (if (procedure? vals-or-procedure)
+                            (vals-or-procedure)
+                            vals-or-procedure)])
+              (list ($var name vals))))))
+
+(define/contract (add-var! csp name [vals-or-procedure empty])
+  (($csp? $var-name?) ((or/c (listof any/c) procedure?)) . ->* . void?)
+  (add-vars! csp (list name) vals-or-procedure))
 
 (define/contract (add-constraint! csp proc var-names)
   ($csp? procedure? (listof $var-name?) . -> . void?)
   (for ([name (in-list var-names)])
-    (check-name-in-csp! 'add-constraint! csp name))
-  (set-$csp-constraints! csp (cons ($constraint var-names proc) ($csp-constraints csp))))
+       (check-name-in-csp! 'add-constraint! csp name))
+  (set-$csp-constraints! csp (append ($csp-constraints csp) (list ($constraint var-names proc)))))
 
 (define/contract (no-solutions? csp)
   ($csp? . -> . boolean?)
   (for/or ([var (in-list ($csp-vars csp))])
-    (empty? ($var-vals var))))
+          (empty? ($var-vals var))))
 
 (struct $csp-inconsistent () #:transparent)
 
@@ -72,12 +73,12 @@
   ($csp? unary-constraint? . -> . $csp?)
   (match-define ($constraint (list constraint-name) proc) constraint)
   (define new-csp ($csp (for/list ([var (in-list ($csp-vars csp))])
-                          (match-define ($var name vals) var)
-                          (if (eq? name constraint-name)
-                              ($var name (if (promise? proc)
-                                             (force proc)
-                                             (filter proc vals)))
-                              var))
+                                  (match-define ($var name vals) var)
+                                  (if (eq? name constraint-name)
+                                      ($var name (if (promise? proc)
+                                                     (force proc)
+                                                     (filter proc vals)))
+                                      var))
                         ;; once the constraint is applied, it can go away
                         (remove constraint ($csp-constraints csp))))
   (when (no-solutions? new-csp) (raise ($csp-inconsistent)))
@@ -95,11 +96,11 @@
   (check-name-in-csp! '$csp-vals csp name)
   (for/first ([var (in-list ($csp-vars csp))]
               #:when (eq? name ($var-name var)))
-    ($var-vals var)))
+             ($var-vals var)))
 
 (struct $arc (name constraint) #:transparent)
 
-(define/contract (revise csp arc)
+(define/contract (reduce-domains-by-arc csp arc)
   ($csp? $arc? . -> . $csp?)
   (match-define ($arc name ($constraint names constraint-proc)) arc)
   (match-define (list other-name) (remove name names))
@@ -108,7 +109,7 @@
                    (λ (val other-val) (constraint-proc other-val val)))) ; otherwise reverse arg order
   (define (satisfies-arc? val)
     (for/or ([other-val (in-list ($csp-vals csp other-name))])
-      (proc val other-val)))
+            (proc val other-val)))
   (apply-unary-constraint csp ($constraint (list name)
                                            (procedure-rename
                                             satisfies-arc?
@@ -118,30 +119,26 @@
   ((listof binary-constraint?) . -> . (listof $arc?))
   (for*/list ([constraint (in-list constraints)]
               [name (in-list ($constraint-names constraint))])
-    ($arc name constraint)))
+             ($arc name constraint)))
 
 (define/contract (terminating-at arcs name)
   ((listof $arc?) $var-name? . -> . (listof $arc?))
   (for/list ([arc (in-list arcs)]
              #:when (eq? name (second ($constraint-names ($arc-constraint arc)))))
-    arc))
-
-(define/contract (constraint-names-assigned? csp constraint)
-  ($csp? $constraint? . -> . boolean?)
-  (define assigned-var-names
-    (for/list ([var (in-list (assigned-vars csp))])
-      ($var-name var)))
-  (match-define ($constraint names _) constraint)
-  (for/and ([name (in-list names)])
-    (memq name assigned-var-names)))
-
-(define/contract (remove-obsolete-constraints csp)
+            arc))
+
+(define/contract (constraint-assigned? csp constraint)
+  ($csp? $constraint? . -> . any/c)
+  (for/and ([name (in-list ($constraint-names constraint))])
+           (memq name (map $var-name (assigned-vars csp)))))
+
+(define/contract (remove-assigned-constraints csp)
   ($csp? . -> . $csp?)
   ($csp
    ($csp-vars csp)
    (for/list ([constraint (in-list ($csp-constraints csp))]
-              #:unless (constraint-names-assigned? csp constraint))
-     constraint)))
+              #:unless (constraint-assigned? csp constraint))
+             constraint)))
 
 (define/contract (ac-3 csp)
   ($csp? . -> . $csp?)
@@ -149,13 +146,13 @@
   (define all-arcs (binary-constraints->arcs (filter binary-constraint? ($csp-constraints csp))))
   (for/fold ([csp csp]
              [arcs all-arcs]
-             #:result (remove-obsolete-constraints csp))
+             #:result (remove-assigned-constraints csp))
             ([i (in-naturals)]
              #:break (empty? arcs))
     (match-define (cons arc other-arcs) arcs)
     (match-define ($arc name _) arc)
-    (define revised-csp (revise csp arc))
-    (values revised-csp (if (= (length ($csp-vals csp name)) (length ($csp-vals revised-csp name)))
+    (define reduced-csp (reduce-domains-by-arc csp arc))
+    (values reduced-csp (if (= (length ($csp-vals csp name)) (length ($csp-vals reduced-csp name)))
                             ;; revision did not reduce the domain, so keep going
                             other-arcs
                             ;; revision reduced the domain, so supplement the list of arcs
@@ -189,10 +186,10 @@
 
 (define/contract (select-unassigned-var csp)
   ($csp? . -> . $var?)
-  ;; minimum remaining values (MRV) rule
   (define uvars (unassigned-vars csp))
   (when (empty? uvars)
-    (raise-argument-error 'select-unassigned-var "nonempty list of vars" uvars))
+    (raise-argument-error 'select-unassigned-var "csp with unassigned vars" csp))
+  ;; minimum remaining values (MRV) rule
   (argmin (λ (var) (length ($var-vals var))) uvars))
 
 (define/contract (order-domain-values vals)
@@ -203,57 +200,46 @@
 ;; todo: inferences between assignments
 (define infer values)
 
+(define/contract (constraint-has-name? constraint name)
+  ($constraint? $var-name? . -> . boolean?)
+  (and (memq name ($constraint-names constraint)) #true))
+
 (define/contract (assign-val csp name val)
   ($csp? $var-name? any/c . -> . $csp?)
-  (validate-assignment (apply-unary-constraint csp ($constraint (list name) (delay (list val)))) name))
-
-(define/contract (validate-assignment csp name)
-  ($csp? $var-name? . -> . $csp?)
-  (define assigned-names (map $var-name (assigned-vars csp)))
-  (for/fold ([csp csp])
+  (define csp-with-assignment (apply-unary-constraint csp ($constraint (list name) (delay (list val)))))
+  (for/fold ([csp csp-with-assignment])
             ([constraint (in-list ($csp-constraints csp))]
-             #:when (match-let ([($constraint cnames _) constraint])
-                      (and (memq name cnames)
-                           (for/and ([cname (in-list cnames)])
-                             (memq cname assigned-names)))))
+             #:when (and (constraint-has-name? constraint name)
+                         (constraint-assigned? csp constraint)))
     (unless (constraint csp) (raise ($csp-inconsistent)))
-    (remove-obsolete-constraints csp)))
+    (remove-assigned-constraints csp)))
 
-(define solver-stop-val (gensym 'solver-stop))
-(define/contract (backtracking-solution-generator csp)
+(define/contract (backtracking-solver csp)
   ($csp? . -> . generator?)
   (generator ()
-             (begin0
-               solver-stop-val
-               (let backtrack ([csp csp])
-                 (cond
-                   [(assignment-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 ([$csp-inconsistent? (const #f)])
-                        (backtrack (infer (assign-val csp name val)))))])))))
-
-(define (backtracking-solver csp)
-  (backtracking-solution-generator (make-arcs-consistent (make-nodes-consistent csp))))
-     
-(define/contract (solve csp [finish-proc values])
-  (($csp?) (procedure?) . ->* . any/c)
-  (or
-   (for/first ([solution (in-producer (backtracking-solver csp) solver-stop-val)])
-     (finish-proc solution))
-   (raise ($csp-inconsistent))))
-
-(define/contract (solve* csp [finish-proc values])
-  (($csp?) (procedure?) . ->* . (listof any/c))
-  (define solutions (for/list ([solution (in-producer (backtracking-solver csp) solver-stop-val)])
-                      (finish-proc solution)))
-  (when (empty? solutions) (raise ($csp-inconsistent)))
+             (let backtrack ([csp (make-arcs-consistent (make-nodes-consistent csp))])
+               (cond
+                 [(assignment-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 ([$csp-inconsistent? (const #f)])
+                         (backtrack (infer (assign-val csp name val)))))]))))
+
+(define/contract (solve* csp [finish-proc values][solution-limit +inf.0])
+  (($csp?) (procedure? integer?) . ->* . (listof any/c))
+  (define solutions
+    (for/list ([solution (in-producer (backtracking-solver csp) (void))]
+               [idx (in-range solution-limit)])
+              (finish-proc solution)))
+  (unless (pair? solutions) (raise ($csp-inconsistent)))
   solutions)
 
+(define/contract (solve csp [finish-proc values])
+  (($csp?) (procedure?) . ->* . any/c)
+  (first (solve* csp finish-proc 1)))
 
-(define ($csp-ref csp name)
-  (car ($csp-vals csp name)))
+(define ($csp-ref csp name) (car ($csp-vals csp name)))
 
 (define/contract (alldiff . xs)
   (() #:rest (listof any/c) . ->* . boolean?)

csp/test.rkt

@@ -10,17 +10,17 @@
 (add-constraint! demo alldiff '(t w o))
 (add-constraint! demo < '(t w o))
 
-(check-equal? (solve demo) ($csp (list ($var 'o '(2)) ($var 'w '(1)) ($var 't '(0))) '()))
+(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) (range 10))
+(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)))))
+             (* (list-ref xs i) (expt 10 i)))))
 
 (add-constraint! ttf alldiff '(t w o f u r))
 (add-constraint! ttf (λ (t w o f u r) (= (+ (word-value t w o) (word-value t w o))
@@ -28,22 +28,22 @@
 (add-constraint! ttf positive? '(t))
 (add-constraint! ttf positive? '(f))
 
-(define ttf-solution (solve ttf)) 
+(define ttf-solution (time (solve ttf))) 
 (check-equal? ttf-solution
               ($csp
                (list
-                ($var 'r '(0))
-                ($var 'u '(3))
+                ($var 't '(9))
+                ($var 'w '(3))
+                ($var 'o '(8))
                 ($var 'f '(1))
-                ($var 'o '(5))
-                ($var 'w '(6))
-                ($var 't '(7)))
+                ($var 'u '(7))
+                ($var 'r '(6)))
                '()))
 
 (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? (solve ttf-solution ttf-print) "765 + 765 = 1530")
+(check-equal? (time (solve ttf-solution ttf-print)) "938 + 938 = 1876")
 
 
 ;; ABC problem:
@@ -61,11 +61,11 @@
     (/ (+ (* 100 a) (* 10 b) c) (+ a b c))))
 
 
-(define abc-sols (solve* abc))
+(define abc-sols (time (solve* abc)))
 (check-equal? (* 9 9 9) (length abc-sols))
 (check-equal?
  (argmin solution-score abc-sols)
- ($csp (list ($var 'c '(9)) ($var 'b '(9)) ($var 'a '(1))) '()))
+ ($csp (list ($var 'a '(1)) ($var 'b '(9)) ($var 'c '(9))) '()))
 
 
 ;; quarter problem:
@@ -76,8 +76,8 @@
 (add-vars! quarter-problem '(dollars quarters) (range 26))
 (add-constraint! quarter-problem (λ (d q) (= 26 (+ d q))) '(dollars quarters))
 (add-constraint! quarter-problem (λ (d q) (= 17 (+ d (* 0.25 q)))) '(dollars quarters))
-(check-equal? (solve quarter-problem)
-              ($csp (list ($var 'quarters '(12)) ($var 'dollars '(14))) '()))
+(check-equal? (time (solve quarter-problem))
+              ($csp (list ($var 'dollars '(14)) ($var 'quarters '(12))) '()))
 
 
 ;; nickel problem
@@ -90,8 +90,8 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu
 (add-constraint! ndq-problem (λ (n d q) (= 330 (+ (* n 5) (* d 10) (* q 25)))) '(n d q))
 (add-constraint! ndq-problem (λ (n q) (= (* 3 q) n)) '(n q))
 (add-constraint! ndq-problem (λ (d n) (= (* 2 d) n)) '(d n))
-(check-equal? (solve ndq-problem)
-              ($csp (list ($var 'q '(6)) ($var 'd '(9)) ($var 'n '(18))) '()))
+(check-equal? (time (solve ndq-problem))
+              ($csp (list ($var 'n '(18)) ($var 'd '(9)) ($var 'q '(6))) '()))
 
 
 ;; xsum
@@ -109,16 +109,14 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu
 
 (define xsum-problem (make-csp))
 (add-vars! xsum-problem '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 1 10))
-(add-constraint! xsum-problem (λ (l1 l2 l3 l4 x) 
-                                (and (< l1 l2 l3 l4)
-                                     (= 27 (+ l1 l2 l3 l4 x)))) '(l1 l2 l3 l4 x))
-(add-constraint! xsum-problem (λ (r1 r2 r3 r4 x) 
-                                (and (< r1 r2 r3 r4)
-                                     (= 27 (+ r1 r2 r3 r4 x)))) '(r1 r2 r3 r4 x))
+(add-constraint! xsum-problem < '(l1 l2 l3 l4))
+(add-constraint! xsum-problem < '(r1 r2 r3 r4))
+(add-constraint! xsum-problem (λ (l1 l2 l3 l4 x) (= 27 (+ l1 l2 l3 l4 x))) '(l1 l2 l3 l4 x))
+(add-constraint! xsum-problem (λ (r1 r2 r3 r4 x)  (= 27 (+ r1 r2 r3 r4 x))) '(r1 r2 r3 r4 x))
 (add-constraint! xsum-problem alldiff '(l1 l2 l3 l4 r1 r2 r3 r4 x))
 
 ;; todo: too slow
-#;(check-equal? (length (solve* xsum-problem)) 8)
+#;(check-equal? (length (time (solve* xsum-problem))) 8)
 
 
 ;; send more money problem
@@ -138,7 +136,7 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu
 (add-constraint! smm positive? '(m))
 (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))
+                          (word-value m o n e y))) '(s e n d m o r y))
 (add-constraint! smm alldiff '(s e n d m o r y))
 
 ;; todo: too slow
@@ -153,12 +151,12 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu
 (for* ([(qa qa-col) (in-indexed queens)]
        [(qb qb-col) (in-indexed queens)]
        #:when (< qa-col qb-col))
-  (add-constraint! queens-problem
-                   (λ (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)))
+      (add-constraint! queens-problem
+                       (λ (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 (solve* queens-problem)))