arity reduction

csp/csp.rkt

@@ -130,7 +130,7 @@
   (apply-unary-constraint csp ($constraint (list name)
                                            (procedure-rename
                                             satisfies-arc?
-                                            (string->symbol (format "satisfies-arc-with-~a?" other-name))))))
+                                            (string->symbol (format "~a-arc-to-~a" (object-name proc)  other-name))))))
 
 (define/contract (binary-constraints->arcs constraints)
   ((listof binary-constraint?) . -> . (listof $arc?))
@@ -150,7 +150,7 @@
     (memq name (map $var-name (assigned-vars csp)))))
 
 (define/contract (remove-assigned-constraints csp [arity #false])
-  (($csp?) (exact-nonnegative-integer?) . ->* . $csp?)
+  (($csp?) ((or/c #false exact-nonnegative-integer?)) . ->* . $csp?)
   ($csp
    ($csp-vars csp)
    (for/list ([constraint (in-list ($csp-constraints csp))]
@@ -222,24 +222,69 @@
   ($constraint? $var-name? . -> . boolean?)
   (and (memq name ($constraint-names constraint)) #true))
 
-(define/contract (test-assignments csp)
+(define/contract (validate-assignments csp)
   ($csp? . -> . $csp?)
-  (define assigned-names (map $var-name (assigned-vars csp)))
-  (for/fold ([csp csp])
-            ([constraint (in-list ($csp-constraints csp))]
+  (for ([constraint (in-list ($csp-constraints csp))]
         #:when (constraint-assigned? csp constraint))
-    (unless (constraint csp) (raise (inconsistency-error)))
-    (remove-assigned-constraints csp)))
+    (unless (constraint csp) (raise (inconsistency-error))))
+  (reduce-constraint-arity (remove-assigned-constraints csp)))
 
 (define/contract (assign-val csp name val)
   ($csp? $var-name? any/c . -> . $csp?)
   (define csp-with-assignment (apply-unary-constraint csp ($constraint (list name) (delay (list val)))))
-  (test-assignments csp-with-assignment))
+  (validate-assignments csp-with-assignment))
+
+(define (reduce-arity proc args)
+  (procedure-rename
+   (λ xs
+     (apply proc (for/fold ([acc empty]
+                            [xs xs]
+                            [vals (filter-not symbol? args)]
+                            #:result (reverse acc))
+                           ([arg (in-list args)])
+                   (if (symbol? arg)
+                       (values (cons (car xs) acc) (cdr xs) vals)
+                       (values (cons (car vals) acc) xs (cdr vals))))))
+   (string->symbol (format "reduced-arity-~a" (object-name proc)))))
+
+(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 (reduce-constraint-arity csp [minimum-arity 3])
+  (($csp?) (exact-nonnegative-integer?) . ->* . $csp?)
+  (define assigned-names (map $var-name (assigned-vars csp)))
+  ($csp ($csp-vars csp)
+        (for/list ([constraint (in-list ($csp-constraints csp))])
+          (match-define ($constraint cnames proc) constraint)
+          (cond
+            [(and (<= minimum-arity (length cnames))
+                  (for/or ([cname (in-list cnames)])
+                    (memq cname assigned-names)))
+             ($constraint (for/list ([cname (in-list cnames)]
+                                     #:unless (memq cname assigned-names))
+                            cname)
+                          (reduce-arity proc (for/list ([cname (in-list cnames)])
+                                               (if (memq cname assigned-names)
+                                                   (car ($csp-vals csp cname))
+                                                   cname))))]
+            [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))) '())))
 
 ;; todo: inferences between assignments
 (define/contract (infer csp)
   ($csp? . -> . $csp?)
-  (test-assignments (make-arcs-consistent csp)))
+  (validate-assignments (make-arcs-consistent csp)))
 
 (define/contract (backtracking-solver csp)
   ($csp? . -> . generator?)