more

csp/csp.rkt

@@ -229,18 +229,14 @@
     [(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))))
+     (define mrv-arg (argmin remaining-values uvars))
+     (match (filter (λ (var) (= (remaining-values mrv-arg) (remaining-values var))) uvars)
        [(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)))
+        (define max-degree-arg (argmax (λ (var) (var-degree csp var)) mrv-uvars))
         ;; 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))])])]))
+        (first (shuffle (filter (λ (var) (= (var-degree csp max-degree-arg) (var-degree csp var))) mrv-uvars)))])]))
 
 (define/contract (order-domain-values vals)
   ((listof any/c) . -> . (listof any/c))
@@ -268,6 +264,7 @@
   (unless (match (procedure-arity proc)
             [(arity-at-least val) (<= val (length pattern))]
             [(? number? val) (= val (length pattern))])
+    #R proc
     (raise-argument-error 'reduce-arity (format "list of length ~a, same as procedure arity" (procedure-arity proc)) pattern))
   (define reduced-arity-name (string->symbol (format "reduced-arity-~a" (object-name proc))))
   (define-values (id-names vals) (partition symbol? pattern))
@@ -313,13 +310,14 @@
 (define/contract (in-solutions csp)
   ($csp? . -> . sequence?)
   ;; as described by AIMA @ 271
-  (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))))]))))
+  (in-generator (let ((max-places (processor-count))) 
+                  (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?) . ->* . (non-empty-listof any/c))
@@ -336,9 +334,9 @@
 
 (define ($csp-ref csp name) (first ($csp-vals csp name)))
 
-(define/contract (alldiff x y)
+(define/contract (alldiff . xs)
   (any/c any/c . -> . boolean?)
-  (not (equal? x y)))
+  (= (length (remove-duplicates xs)) (length xs)))
 
 (define/contract (alldiff= x y)
   (any/c any/c . -> . boolean?)

csp/port/test-problems.rkt

@@ -110,6 +110,28 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu
 |#
 
 
+(define smm (new problem%))
+(send smm add-variables '(s e n d m o r y) (range 10))
+(send smm add-constraint (λ(x) (> x 0)) '(s))
+(send smm add-constraint (λ(x) (> x 0)) '(m))
+(send smm add-constraint (λ(d e y) (= (modulo (+ d e) 10) y)) '(d e y))
+(send smm 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 smm 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 smm 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 smm add-constraint (new all-different-constraint%))
+(send smm add-constraint (λ xs (= (length (remove-duplicates xs)) (length xs))) '(s e n d m o r y))
+
+(check-hash-items (send smm get-solution) '#hash((m . 1) (e . 5) (r . 8) (n . 6) (y . 2) (o . 0) (d . 7) (s . 9)))
+
+
+
+
 ;; queens problem
 ;; place queens on chessboard so they do not intersect
 

csp/test.rkt

@@ -15,7 +15,11 @@
 (check-equal? 10 ((reduce-arity f '(a b 3 d)) 1 2 4))
 |#
 
-(make-nodes-consistent ($csp (list ($var 'a '(1)) ($var 'b '(0 1))) (list ($constraint '(b) zero?))))
+(define c1 ($csp (list ($var 'a '(1 2)) ($var 'b '(1 2 3)) ($var 'c '(1 3 4 5))) (list ($constraint '(a b c) alldiff))))
+(assign-val c1 'b 3)
+
+(define c2 ($csp (list ($var 'a '(1 2)) ($var 'b '(1 2 3)) ($var 'c '(1 3 4 5))) null))
+(add-pairwise-constraint! c2 alldiff '(a b c))
+(assign-val c2 'b 3)
 
-(remove-assigned-constraints ($csp (list ($var 'a '(1)) ($var 'b '(0 1))) (list ($constraint '(b) zero?))))