diff --git a/csp/csp.rkt b/csp/csp.rkt index a2b4641f..9411be3a 100644 --- a/csp/csp.rkt +++ b/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)) diff --git a/csp/test.rkt b/csp/test.rkt index 41978d41..02a7f014 100644 --- a/csp/test.rkt +++ b/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) \ No newline at end of file