werk

csp/csp.rkt

@@ -328,35 +328,35 @@
 (define/contract (select-k names krecs)
   ((listof $var-name?) (listof (cons/c $var-name? continuation?)) . -> . continuation?)
   ;; select the most recent (ie topmost) k that is in the signal
+  ;; todo: repair backjumping
   (cdr (or #;(for/first ([krec (in-list krecs)]
-                       #:when (let ([name (car krec)])
-                                (memq name names)))
-             krec)
+                         #:when (let ([name (car krec)])
+                                  (memq name names)))
+               krec)
            (first krecs))))
 
 (define/contract (backtrack-solution-generator csp)
   ($csp? . -> . generator?)
   ;; as described by AIMA @ 271
-  (generator () (let ((max-places (processor-count))) 
-                  (let backtrack ([csp (make-arcs-consistent (make-nodes-consistent csp))]
-                                  [backjump-krecs null])
-                    (match (select-unassigned-var csp)
-                      [#f (yield ($csp (for/list ([v (in-list ($csp-vars csp))])
-                                         (match v
-                                           [($varc name vals _) ($var name vals)]
-                                           [(? $var? v) v]))
-                                       ($csp-constraints csp)))]
-                      [($var name vals)
-                       (call/prompt
-                        (λ ()
-                          (for ([val (in-list (order-domain-values vals))])
-                            (let/cc backjump-k
-                              (let ([backjump-krecs (cons (cons name backjump-k) backjump-krecs)])
-                                (with-handlers ([inconsistency-signal?
-                                                 (λ (sig)
-                                                   (define backjump-k (select-k (inconsistency-signal-names sig) backjump-krecs))
-                                                   (backjump-k))])
-                                  (backtrack (assign-val csp name val) backjump-krecs)))))))])))))
+  (generator () (let backtrack ([csp (make-arcs-consistent (make-nodes-consistent csp))]
+                                [backjump-krecs null])
+                  (match (select-unassigned-var csp)
+                    [#f (yield ($csp (for/list ([v (in-list ($csp-vars csp))])
+                                       (match v
+                                         [($varc name vals _) ($var name vals)]
+                                         [(? $var? v) v]))
+                                     ($csp-constraints csp)))]
+                    [($var name vals)
+                     (call/prompt
+                      (thunk
+                       (for ([val (in-list (order-domain-values vals))])
+                         (let/cc backjump-k
+                           (let ([backjump-krecs (cons (cons name backjump-k) backjump-krecs)])
+                             (with-handlers ([inconsistency-signal?
+                                              (λ (sig)
+                                                (define backjump-k (select-k (inconsistency-signal-names sig) backjump-krecs))
+                                                (backjump-k))])
+                               (backtrack (assign-val csp name val) backjump-krecs)))))))]))))
 
 (define/contract (solve* csp [finish-proc values][solution-limit +inf.0])
   (($csp?) (procedure? integer?) . ->* . (non-empty-listof any/c))

csp/test.rkt

@@ -1,25 +1,9 @@
 #lang at-exp racket
 (require "csp.rkt" rackunit)
 
-#|
-(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 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)
 
+(define c (make-csp '((a (2 3)) (b (12 14 16)) (c (2 5)))
+                    (list ($constraint '(a c) alldiff=)
+                          ($constraint '(b c) (λ (b c) (zero? (modulo b c)))))))
 
+(solve c)