diff --git a/csp/constraint.rkt b/csp/constraint.rkt index 79faf7d7..c0d54a09 100644 --- a/csp/constraint.rkt +++ b/csp/constraint.rkt @@ -1,12 +1,12 @@ #lang racket/base -(require racket/class sugar/container sugar/list sugar/debug racket/list "helper.rkt" "variable.rkt") +(require racket/class racket/bool sugar/container sugar/list sugar/debug racket/list "helper.rkt" "variable.rkt") (provide (all-defined-out)) (define constraint% (class object% (super-new) - (define/public (broken? 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))] - #:unless (broken? variables domains (make-hash (list (cons variable value))))) + #:unless (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 (broken? variables domains assignments)) + (unless (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 (broken? 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 (broken? 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 (broken? 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) @@ -118,7 +118,7 @@ _unassigned)) (cond [(equal? singlevalue _unassigned) (set! singlevalue value)] - [(and (not (equal? value _unassigned)) (not (equal? value singlevalue))) + [(nor (equal? value _unassigned) (equal? value singlevalue)) (set! return-value #f) (return-k)])) (when (and forward-check? (not (equal? singlevalue _unassigned))) diff --git a/csp/helper.rkt b/csp/helper.rkt index 817d7c7b..fbe1ecdd 100644 --- a/csp/helper.rkt +++ b/csp/helper.rkt @@ -3,6 +3,14 @@ (provide (all-defined-out)) (require rackunit) +(define-syntax-rule (forever expr ...) + (for ([i (in-naturals)]) + expr ...)) + +(define-syntax-rule (forever/or expr ...) + (for/or ([i (in-naturals)]) + expr ...)) + (define-syntax-rule (for-each-send proc objects) (for-each (λ(o) (send o proc)) objects)) diff --git a/csp/python-constraint/trials/abc.py b/csp/python-constraint/trials/abcd.py similarity index 100% rename from csp/python-constraint/trials/abc.py rename to csp/python-constraint/trials/abcd.py diff --git a/csp/solver.rkt b/csp/solver.rkt index 71ab5c4a..301adb31 100644 --- a/csp/solver.rkt +++ b/csp/solver.rkt @@ -30,10 +30,10 @@ (define/override (get-solution-iter domains constraints vconstraints) (define sorted-variables - (map last (sort (for/list ([(variable domain) (in-hash domains)]) - (list (- (length (hash-ref vconstraints variable))) ; first two elements used for sorting - (length (domain)) - variable)) list-comparator))) + (map third (sort (map (λ(var) + (list (- (length (hash-ref vconstraints var))) ; first two elements used for sorting + (length ((hash-ref domains var))) + var)) (hash-keys domains)) list-comparator))) ;; state-retention variables (define possible-solution (make-hash)) (define variable-queue null) @@ -61,34 +61,34 @@ (let/ec exit-k ;; mix the degree and minimum-remaining-values (MRV) heuristics - (let main-loop () - (unless (get-next-unassigned-variable) - (yield (hash-copy possible-solution)) ; if there are no unassigned variables, solution is done. - (if (null? variable-queue) ; if queue isn't empty, return to previous variable, otherwise all done. - (exit-k) - (set!-previous-variable))) - - (let value-checking-loop () ; we have a variable. Do we have any values left? - (when (null? values) ; no, so try going back to last variable and getting some values - (for/or ([i (in-naturals)]) - (when (null? variable-queue) (exit-k)) ; no variables left, so solver is done - (hash-remove! possible-solution variable) - (set!-previous-variable) - (not (null? values)))) - - ;; Got a value. Check it. - (hash-set! possible-solution 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 broken? variables domains possible-solution pushdomains))) - ;; constraint failed, so try again - (for-each-send pop-state pushdomains) - (value-checking-loop))) - - ;; Push state before looking for next variable. - (set! variable-queue (cons (vvp variable values pushdomains) variable-queue)) - (main-loop)) + (forever + (unless (get-next-unassigned-variable) + (yield (hash-copy possible-solution)) ; if there are no unassigned variables, solution is complete. + (if (null? variable-queue) ; then, if queue is empty ... + (exit-k) ; all done, no other solutions possible. + (set!-previous-variable))) ; or queue is not empty, so return to previous variable + + (let value-checking-loop () ; we have a variable. Do we have any values left? + (when (null? values) ; no, so try going back to last variable and getting some values + (forever/or + (when (null? variable-queue) (exit-k)) ; no variables left, so solver is done + (hash-remove! possible-solution variable) + (set!-previous-variable) + (not (null? values)))) + + ;; Got a value. Check it. + (hash-set! possible-solution variable (car-pop! values)) + (for-each-send push-state pushdomains) + (unless (for/and ([constraint+variables (in-list (hash-ref vconstraints variable))]) + (let ([constraint (car constraint+variables)] + [variables (cadr constraint+variables)]) + (send constraint is-true? variables domains possible-solution pushdomains))) + ;; constraint failed, so try again + (for-each-send pop-state pushdomains) + (value-checking-loop))) + + ;; Push state before looking for next variable. + (set! variable-queue (cons (vvp variable values pushdomains) variable-queue))) (error 'get-solution-iter "impossible to reach this")) (void))