From 85a5db3782786b63c2c40589b0a9ba756feb197d Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 13 Oct 2018 10:57:07 -0700 Subject: [PATCH] clarity --- csp/csp.rkt | 60 +++++++++++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/csp/csp.rkt b/csp/csp.rkt index c317cb21..a00922ff 100644 --- a/csp/csp.rkt +++ b/csp/csp.rkt @@ -30,7 +30,7 @@ (raise-argument-error caller (format "one of these existing csp var names: ~v" names) name))) (define (nary-constraint? constraint n) - (= n (length ($constraint-names constraint)))) + (= n (constraint-arity constraint))) (define/contract (unary-constraint? constraint) ($constraint? . -> . boolean?) @@ -80,14 +80,14 @@ (for/or ([var (in-list ($csp-vars csp))]) (zero? (remaining-values var)))) -(struct inconsistency-error () #:transparent) +(struct inconsistency-signal () #:transparent) (define/contract (apply-unary-constraint csp constraint) ($csp? unary-constraint? . -> . $csp?) - (match-define ($constraint (list constraint-name) proc) constraint) + (match-define ($constraint (list cname) proc) constraint) (define new-csp ($csp (for/list ([var (in-list ($csp-vars csp))]) (match-define ($var name vals) var) - (if (eq? name constraint-name) + (if (eq? name cname) ;; special rule: use promise for a constant value ;; to skip the filtering ($var name (if (promise? proc) @@ -98,7 +98,7 @@ ;; ps this is not the same as an "assigned" constraint ;; because the var may still have multiple values (remove constraint ($csp-constraints csp)))) - (when (no-solutions? new-csp) (raise (inconsistency-error))) + (when (no-solutions? new-csp) (raise (inconsistency-signal))) new-csp) (define/contract (make-nodes-consistent csp) @@ -122,7 +122,7 @@ (match-define ($arc name ($constraint names constraint-proc)) arc) (match-define (list other-name) (remove name names)) (define proc (if (eq? name (first names)) ; name is on left - constraint-proc ; so val goes on left + constraint-proc ; so val stays on left (λ (val other-val) (constraint-proc other-val val)))) ; otherwise reverse arg order (define (satisfies-arc? val) (for/or ([other-val (in-list ($csp-vals csp other-name))]) @@ -154,7 +154,7 @@ ($csp ($csp-vars csp) (for/list ([constraint (in-list ($csp-constraints csp))] - #:unless (and (if arity (= (length ($constraint-names constraint)) arity) #true) + #:unless (and (if arity (= arity (constraint-arity constraint)) #true) (constraint-assigned? csp constraint))) constraint))) @@ -205,6 +205,10 @@ (match-define-values (assigned unassigned) (assigned-helper csp)) assigned) +(define/contract (constraint-arity constraint) + ($constraint? . -> . exact-nonnegative-integer?) + (length ($constraint-names constraint))) + (define/contract (var-degree csp var) ($csp? $var? . -> . exact-nonnegative-integer?) (for/sum ([constraint (in-list ($csp-constraints csp))] @@ -235,15 +239,16 @@ (define/contract (validate-assignments csp) ($csp? . -> . $csp?) - (for ([constraint (in-list ($csp-constraints csp))] - #:when (constraint-assigned? csp constraint)) - (unless (constraint csp) (raise (inconsistency-error)))) + (define assigned-constraints (filter (λ (c) (constraint-assigned? csp c)) ($csp-constraints csp))) + (for ([constraint (in-list (sort assigned-constraints < #:key constraint-arity))] + #:unless (constraint csp)) + (raise (inconsistency-signal))) (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))))) - (validate-assignments csp-with-assignment)) + (define assignment-constraint ($constraint (list name) (delay (list val)))) + (validate-assignments (apply-unary-constraint csp assignment-constraint))) (define (reduce-arity proc pattern) (unless (match (procedure-arity proc) @@ -278,21 +283,22 @@ (define/contract (reduce-constraint-arity csp [minimum-arity 3]) (($csp?) (exact-nonnegative-integer?) . ->* . $csp?) - (define assigned-names (map $var-name (assigned-vars csp))) + (define (assigned-name? cname) (memq cname (map $var-name (assigned-vars csp)))) + (define (partially-assigned? constraint) + (ormap assigned-name? ($constraint-names constraint))) ($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))))] + [(and (<= minimum-arity (constraint-arity constraint)) + (partially-assigned? constraint)) + (match-define ($constraint cnames proc) constraint) + ($constraint (filter-not assigned-name? cnames) + ;; pattern is mix of values and symbols (indicating variables to persist) + (let ([reduce-arity-pattern (for/list ([cname (in-list cnames)]) + (if (assigned-name? cname) + ($csp-ref csp cname) + cname))]) + (reduce-arity proc reduce-arity-pattern)))] [else constraint])))) (module+ test @@ -315,7 +321,7 @@ [else ;; we have at least 1 unassigned var (match-define ($var name vals) (select-unassigned-var csp)) (for ([val (in-list (order-domain-values vals))]) - (with-handlers ([inconsistency-error? void]) + (with-handlers ([inconsistency-signal? void]) (backtrack (infer (assign-val csp name val)))))])))) (define/contract (solve* csp [finish-proc values][solution-limit +inf.0]) @@ -324,14 +330,14 @@ (for/list ([solution (in-producer (backtracking-solver csp) (void))] [idx (in-range solution-limit)]) (finish-proc solution))) - (unless (pair? solutions) (raise (inconsistency-error))) + (unless (pair? solutions) (raise (inconsistency-signal))) solutions) (define/contract (solve csp [finish-proc values]) (($csp?) (procedure?) . ->* . any/c) (first (solve* csp finish-proc 1))) -(define ($csp-ref csp name) (car ($csp-vals csp name))) +(define ($csp-ref csp name) (first ($csp-vals csp name))) (define/contract (alldiff x y) (any/c any/c . -> . boolean?)