From 32079c022078e329735faf424dfcc1322edac603 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 5 Oct 2014 08:37:29 -0700 Subject: [PATCH] nits --- csp/constraint.rkt | 12 ++++++------ csp/solver.rkt | 44 ++++++++++++++++++++------------------------ 2 files changed, 26 insertions(+), 30 deletions(-) diff --git a/csp/constraint.rkt b/csp/constraint.rkt index 1ed991de..79ec866b 100644 --- a/csp/constraint.rkt +++ b/csp/constraint.rkt @@ -6,7 +6,7 @@ (class object% (super-new) - (define/public (call variables domains assignments [forward-check? #f]) + (define/public (is-true? variables domains assignments [forward-check? #f]) ;; Perform the constraint checking ;; If the forwardcheck parameter is not false, besides telling if @@ -31,7 +31,7 @@ (set-field! _list domain (for/fold ([domain-values (domain)]) ([value (in-list (domain))] - #:when (not (call variables domains (make-hash (list (cons variable value)))))) + #:when (not (is-true? variables domains (make-hash (list (cons variable value)))))) (remove value domain-values))) (set! constraints (remove (list this variables) constraints)) (hash-update! vconstraints variable (λ(val) (remove (list this variables) val))))) @@ -50,7 +50,7 @@ (define unassigned-variable-domain (hash-ref domains unassigned-variable)) (for ([value (in-list (unassigned-variable-domain))]) (hash-set! assignments unassigned-variable value) - (when (not (call variables domains assignments)) + (when (not (is-true? variables domains assignments)) (send unassigned-variable-domain hide-value value))) (hash-remove! assignments unassigned-variable) (not (null? unassigned-variable-domain))] ; if domain had no remaining values, the constraint will be impossible to meet, so return #f @@ -69,7 +69,7 @@ (inherit forward-check) - (define/override (call variables domains assignments [forward-check? #f] [_unassigned Unassigned]) + (define/override (is-true? variables domains assignments [forward-check? #f] [_unassigned Unassigned]) (define parms (map (λ(v) (hash-ref assignments v _unassigned)) variables)) (define missing (length (filter (λ(p) (equal? p _unassigned)) parms))) (if (> missing 0) @@ -85,7 +85,7 @@ (class constraint% (super-new) - (define/override (call variables domains assignments [forward-check? #f] [_unassigned Unassigned]) + (define/override (is-true? variables domains assignments [forward-check? #f] [_unassigned Unassigned]) (define-values (assigned-vars unassigned-vars) (partition (λ(var) (hash-has-key? assignments var)) variables)) (define assigned-values (map (λ(var) (hash-ref assignments var)) assigned-vars)) @@ -106,7 +106,7 @@ (class constraint% (super-new) - (define/override (call variables domains assignments [forward-check? #f] [_unassigned Unassigned]) + (define/override (is-true? variables domains assignments [forward-check? #f] [_unassigned Unassigned]) (define singlevalue _unassigned) (define value #f) (define domain #f) diff --git a/csp/solver.rkt b/csp/solver.rkt index 52f09337..75dddd16 100644 --- a/csp/solver.rkt +++ b/csp/solver.rkt @@ -74,30 +74,26 @@ [else (set! want-to-return #t) (return-k)])) - (let/ec break-loop2 - (let loop2 () - ;; We have a variable. Do we have any values left? - (when (null? values) - ;; No. Go back to last variable, if there's one, else exit. - (for/or ([i (in-naturals)]) - (hash-remove! assignments variable) - (when (null? queue) (set! want-to-return #t) (return-k)) - (set!-values (variable values pushdomains) (pop-vvp-values! queue)) - (for-each-send pop-state pushdomains) - (not (null? values)))) - - ;; Got a value. Check it. - (hash-set! assignments variable (car-pop! values)) - (for-each-send push-state pushdomains) - (let/ec break-for-loop - (if (for/or ([cvpair (in-list (hash-ref vconstraints variable))]) - (match-define (list constraint variables) cvpair) - (not (send constraint call variables domains assignments pushdomains))) - (break-for-loop) - (break-loop2))) - - (for-each-send pop-state pushdomains) - (loop2))) + (let constraint-checking-loop () + ;; We have a variable. Do we have any values left? + (when (null? values) + ;; No. Go back to last variable, if there is one, otherwise solver is done. + (for/or ([i (in-naturals)]) + (hash-remove! assignments variable) + (when (null? queue) (set! want-to-return #t) (return-k)) + (set!-values (variable values pushdomains) (pop-vvp-values! queue)) + (for-each-send pop-state pushdomains) + (not (null? values)))) + + ;; Got a value. Check it. + (hash-set! assignments variable (car-pop! values)) + (for-each-send push-state pushdomains) + (when (for/or ([cvpair (in-list (hash-ref vconstraints variable))]) + (match-define (list constraint variables) cvpair) + (not (send constraint is-true? variables domains assignments pushdomains))) + ;; constraint failed, so try again + (for-each-send pop-state pushdomains) + (constraint-checking-loop))) ;; Push state before looking for next variable. (set! queue (cons (vvp variable values pushdomains) queue))