From 400b4849433d2d2b7163e46225fd770f025ffc66 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 22 Oct 2018 18:23:05 -0700 Subject: [PATCH] reality --- csp/csp/hacs-map.rkt | 10 +- csp/csp/hacs-test-queens.rkt | 31 ++++ csp/csp/hacs-test.rkt | 38 ++-- csp/csp/hacs.rkt | 334 +++++++++++++++++------------------ 4 files changed, 216 insertions(+), 197 deletions(-) create mode 100644 csp/csp/hacs-test-queens.rkt diff --git a/csp/csp/hacs-map.rkt b/csp/csp/hacs-map.rkt index 34450098..601f397b 100644 --- a/csp/csp/hacs-map.rkt +++ b/csp/csp/hacs-map.rkt @@ -4,13 +4,13 @@ (define (map-coloring-csp colors neighbors) - (define variables (remove-duplicates (flatten neighbors) eq?)) - (define vds (for/list ([var (in-list variables)]) - ($var var colors))) + (define names (remove-duplicates (flatten neighbors) eq?)) + (define vds (for/list ([name (in-list names)]) + (var name colors))) (define cs (for*/list ([neighbor neighbors] [target (cdr neighbor)]) - ($constraint (list (car neighbor) target) neq?))) - ($csp vds cs)) + (constraint (list (car neighbor) target) neq?))) + (csp vds cs)) (define (parse-colors str) (map string->symbol (map string-downcase (regexp-match* "." str)))) (define(parse-neighbors str) diff --git a/csp/csp/hacs-test-queens.rkt b/csp/csp/hacs-test-queens.rkt new file mode 100644 index 00000000..1bce97c7 --- /dev/null +++ b/csp/csp/hacs-test-queens.rkt @@ -0,0 +1,31 @@ +#lang debug racket +(require sugar/debug "hacs.rkt") + +(current-inference forward-check) +(current-select-variable mrv) +(current-order-values shuffle) +(current-random #true) + +;; queens problem +;; place queens on chessboard so they do not intersect + +(define board-size 8) + +(define queens (make-csp)) +(define qs (for/list ([q board-size]) (string->symbol (format "q~a" q)))) +(define rows (range (length qs))) +(add-vars! queens qs rows) +(define (q-col q) (string->number (string-trim (symbol->string q) "q"))) +(for* ([qs (in-combinations qs 2)]) + (match-define (list qa qb) qs) + (match-define (list qa-col qb-col) (map q-col qs)) + (add-constraint! queens + (λ (qa-row qb-row) + (not (= (abs (- qa-row qb-row)) (abs (- (q-col qa) (q-col qb)))))) ; same diag? + (list qa qb)) + (add-constraint! queens (negate =) (list qa qb))) + +(current-thread-count 4) +(time-avg 10 (solve queens)) +(parameterize ([current-solver min-conflicts-solver]) + (time-avg 10 (solve queens))) \ No newline at end of file diff --git a/csp/csp/hacs-test.rkt b/csp/csp/hacs-test.rkt index 73ff798f..47e48d61 100644 --- a/csp/csp/hacs-test.rkt +++ b/csp/csp/hacs-test.rkt @@ -6,60 +6,60 @@ (current-order-values shuffle) (current-random #true) -(check-equal? (first-unassigned-variable (csp (list (variable 'a (range 3)) (variable 'b (range 3))) null)) - (variable 'a (range 3))) -(check-equal? (first-unassigned-variable (csp (list (avar 'a (range 3)) (variable 'b (range 3))) null)) - (variable 'b (range 3))) +(check-equal? (first-unassigned-variable (csp (list (var 'a (range 3)) (var 'b (range 3))) null)) + (var 'a (range 3))) +(check-equal? (first-unassigned-variable (csp (list (avar 'a (range 3)) (var 'b (range 3))) null)) + (var 'b (range 3))) (check-false (first-unassigned-variable (csp (list (avar 'a (range 3)) (avar 'b (range 3))) null))) (check-equal? ;; no forward checking when no constraints - (csp-vars (forward-check (csp (list (avar 'a '(1)) (variable 'b (range 2))) null) 'a)) - (list (avar 'a '(1)) (variable 'b '(0 1)))) + (csp-vars (forward-check (csp (list (avar 'a '(1)) (var 'b (range 2))) null) 'a)) + (list (avar 'a '(1)) (var 'b '(0 1)))) (check-equal? - (csp-vars (forward-check (forward-check (csp (list (avar 'a '(1)) (avar 'b '(0)) (variable 'c '(0 1 2))) + (csp-vars (forward-check (forward-check (csp (list (avar 'a '(1)) (avar 'b '(0)) (var 'c '(0 1 2))) (list (constraint '(a c) (negate =)) (constraint '(b c) (negate =)))) 'a) 'b)) (list (avar 'a '(1)) (avar 'b '(0)) (cvar 'c '(2) '(b a)))) (check-equal? ;; no inconsistency: b≠c not checked when fc is relative to a - (csp-vars (forward-check (csp (list (avar 'a '(1)) (variable 'b (range 2)) (variable 'c '(0))) + (csp-vars (forward-check (csp (list (avar 'a '(1)) (var 'b (range 2)) (var 'c '(0))) (list (constraint '(a b) (negate =)) (constraint '(b c) (negate =)))) 'a)) - (list (avar 'a '(1)) (cvar 'b '(0) '(a)) (variable 'c '(0)))) + (list (avar 'a '(1)) (cvar 'b '(0) '(a)) (var 'c '(0)))) (check-equal? ;; no inconsistency: a≠b not checked when fc ignores a, which is already assigned - (csp-vars (forward-check (csp (list (avar 'a '(1)) (avar 'b '(1)) (variable 'c (range 2))) + (csp-vars (forward-check (csp (list (avar 'a '(1)) (avar 'b '(1)) (var 'c (range 2))) (list (constraint '(a b) (negate =)) (constraint '(b c) (negate =)))) 'b)) (list (avar 'a '(1)) (avar 'b '(1)) (cvar 'c '(0) '(b)))) -(check-exn $backtrack? +(check-exn backtrack? (λ () (csp-vars (forward-check (csp (list (avar 'a '(1)) - (variable 'b '(1))) + (var 'b '(1))) (list (constraint '(a b) (negate =)))) 'a)))) -(check-equal? (csp-vars (forward-check (csp (list (variable 'a '(0)) - (variable 'b (range 3))) +(check-equal? (csp-vars (forward-check (csp (list (var 'a '(0)) + (var 'b (range 3))) (list (constraint '(a b) <))) 'a)) - (list (variable 'a '(0)) (cvar 'b '(1 2) '(a)))) + (list (var 'a '(0)) (cvar 'b '(1 2) '(a)))) (check-equal? (parameterize ([current-inference forward-check]) - (length (solve* (csp (list (variable 'x (range 3)) - (variable 'y (range 3)) - (variable 'z (range 3))) + (length (solve* (csp (list (var 'x (range 3)) + (var 'y (range 3)) + (var 'z (range 3))) (list (constraint '(x y) <>) (constraint '(x z) <>) (constraint '(y z) <>)))))) 6) (parameterize ([current-inference forward-check]) (define vds (for/list ([k '(wa nt nsw q t v sa)]) - (variable k '(red green blue)))) + (var k '(red green blue)))) (define cs (list (constraint '(wa nt) neq?) (constraint '(wa sa) neq?) diff --git a/csp/csp/hacs.rkt b/csp/csp/hacs.rkt index 8d21eccc..8ce556e3 100644 --- a/csp/csp/hacs.rkt +++ b/csp/csp/hacs.rkt @@ -18,87 +18,85 @@ (for ([arg (in-list (car argss))]) (loop (cdr argss) (cons arg acc)))))))) -(struct csp (vars - constraints - [assignments #:auto] - [checks #:auto]) #:mutable #:transparent - #:auto-value 0) -(define vars csp-vars) +(struct csp (vars constraints [assignments #:auto] [checks #:auto]) + #:mutable #:transparent #:auto-value 0) (define constraints csp-constraints) +(define vars csp-vars) (define-syntax-rule (in-constraints csp) (in-list (csp-constraints csp))) -(define-syntax-rule (in-vars csp) (in-list (csp-vars csp))) -(define-syntax-rule (in-variable-names csp) (in-list (map variable-name (csp-vars csp)))) +(define-syntax-rule (in-vars csp) (in-list (vars csp))) +(define-syntax-rule (in-variable-names csp) (in-list (map var-name (vars csp)))) (struct constraint (names proc) #:transparent #:property prop:procedure (λ (const prob) (unless (csp? prob) - (raise-argument-error '$constraint-proc "$csp" prob)) + (raise-argument-error 'constraint-proc "csp" prob)) ;; apply proc in many-to-many style - (for/and ([args (in-cartesian (map (λ (name) (csp-domain prob name)) (constraint-names const)))]) + (for/and ([args (in-cartesian (map (λ (name) (find-domain prob name)) (constraint-names const)))]) (apply (constraint-proc const) args)))) -(define (make-constraint [names null] [proc values]) - (constraint names proc)) +(define name? symbol?) +(define/contract (make-constraint [names null] [proc values]) + (() ((listof name?) procedure?) . ->* . constraint?) + (constraint names proc)) -(define (csp->graphviz prob) +(define/contract (csp->graphviz prob) + (csp? . -> . string?) (define g (csp->graph prob)) (graphviz g #:colors (coloring/brelaz g))) -(define (csp->graph prob) - (for*/fold ([gr (unweighted-graph/undirected (map variable-name (vars prob)))]) +(define/contract (csp->graph prob) + (csp? . -> . graph?) + (for*/fold ([gr (unweighted-graph/undirected (map var-name (vars prob)))]) ([constraint (in-constraints prob)] [edge (in-combinations (constraint-names constraint) 2)]) (apply add-edge! gr edge) gr)) -(struct variable (name domain) #:transparent) -(define name? symbol?) +(struct var (name domain) #:transparent) +(define domain var-domain) -(struct checked-var variable (past) #:transparent) -(define cvar checked-var) -(define cvar? checked-var?) +(struct checked-variable var (history) #:transparent) +(define history checked-variable-history) +(define cvar checked-variable) +(define cvar? checked-variable?) -(struct assigned-var variable () #:transparent) +(struct assigned-var var () #:transparent) (define avar assigned-var) (define avar? assigned-var?) (define/contract (make-csp [vars null] [consts null]) - (() ((listof variable?) (listof constraint?)) . ->* . csp?) + (() ((listof var?) (listof constraint?)) . ->* . csp?) (csp vars consts)) -(define/contract (add-variables! prob names-or-procedure [vals-or-procedure empty]) +(define/contract (add-vars! prob names-or-procedure [vals-or-procedure empty]) ((csp? (or/c (listof name?) procedure?)) ((or/c (listof any/c) procedure?)) . ->* . void?) - (for/fold ([vars (csp-vars prob)] - #:result (set-csp-vars! prob vars)) + (for/fold ([vrs (vars prob)] + #:result (set-csp-vars! prob vrs)) ([name (in-list (if (procedure? names-or-procedure) (names-or-procedure) names-or-procedure))]) - (when (memq name (map variable-name vars)) + (when (memq name (map var-name vrs)) (raise-argument-error 'add-vars! "var that doesn't already exist" name)) - (append vars (list (variable name - (if (procedure? vals-or-procedure) - (vals-or-procedure) - vals-or-procedure)))))) + (append vrs (list (var name + (if (procedure? vals-or-procedure) + (vals-or-procedure) + vals-or-procedure)))))) -(define add-vars! add-variables!) - -(define/contract (add-variable! prob name [vals-or-procedure empty]) +(define/contract (add-var! prob name [vals-or-procedure empty]) ((csp? name?) ((or/c (listof any/c) procedure?)) . ->* . void?) (add-vars! prob (list name) vals-or-procedure)) -(define add-var! add-variable!) - (define/contract (add-constraints! prob proc namess [proc-name #false]) ((csp? procedure? (listof (listof name?))) ((or/c #false name?)) . ->* . void?) (set-csp-constraints! prob (append (constraints prob) - (for/list ([names (in-list namess)]) - (for ([name (in-list names)]) - (check-name-in-csp! 'add-constraints! prob name)) - (make-constraint names (if proc-name - (procedure-rename proc proc-name) - proc)))))) + (for/list ([names (in-list namess)]) + (for ([name (in-list names)]) + (check-name-in-csp! 'add-constraints! prob name)) + (make-constraint names (if proc-name + (procedure-rename proc proc-name) + proc)))))) (define/contract (add-pairwise-constraint! prob proc var-names [proc-name #false]) ((csp? procedure? (listof name?)) (name?) . ->* . void?) @@ -112,8 +110,8 @@ (any/c any/c . -> . boolean?) (not (= x y))) -(struct $backtrack (names) #:transparent) -(define (backtrack! [names null]) (raise ($backtrack names))) +(struct backtrack (names) #:transparent) +(define (backtrack! [names null]) (raise (backtrack names))) (define current-select-variable (make-parameter #f)) (define current-order-values (make-parameter #f)) @@ -121,32 +119,33 @@ (define current-solver (make-parameter #f)) (define current-random (make-parameter #t)) (define current-decompose (make-parameter #t)) +(define current-thread-count (make-parameter 4)) (define/contract (check-name-in-csp! caller prob name) (symbol? csp? name? . -> . void?) - (define names (map variable-name (vars prob))) + (define names (map var-name (vars prob))) (unless (memq name names) (raise-argument-error caller (format "one of these existing csp var names: ~v" names) name))) -(define/contract (csp-var prob name) - (csp? name? . -> . variable?) - (check-name-in-csp! 'csp-var prob name) - (for/first ([var (in-vars prob)] - #:when (eq? name (variable-name var))) - var)) +(define/contract (find-var prob name) + (csp? name? . -> . var?) + (check-name-in-csp! 'find-var prob name) + (for/first ([vr (in-vars prob)] + #:when (eq? name (var-name vr))) + vr)) -(define/contract (csp-domain prob name) +(define/contract (find-domain prob name) (csp? name? . -> . (listof any/c)) - (check-name-in-csp! 'csp-vals prob name) - (variable-domain (csp-var prob name))) + (check-name-in-csp! 'find-domain prob name) + (domain (find-var prob name))) (define order-domain-values values) (define/contract (assigned-name? prob name) (csp? name? . -> . any/c) - (for/or ([var (in-vars prob)] - #:when (assigned-var? var)) - (eq? name (variable-name var)))) + (for/or ([vr (in-vars prob)] + #:when (assigned-var? vr)) + (eq? name (var-name vr)))) (define/contract (reduce-function-arity proc pattern) (procedure? (listof any/c) . -> . procedure?) @@ -172,97 +171,91 @@ reduced-arity-name)) (define/contract (reduce-constraint-arity prob [minimum-arity 3]) - ((csp?) ((or/c #false exact-nonnegative-integer?)) . ->* . csp?) - (let ([assigned-name? (curry assigned-name? prob)]) - (define (partially-assigned? constraint) - (ormap assigned-name? (constraint-names constraint))) - (make-csp (vars prob) - (for/list ([const (in-constraints prob)]) - (cond - [(and (or (not minimum-arity) (<= minimum-arity (constraint-arity const))) - (partially-assigned? const)) - (match-define (constraint cnames proc) const) - (constraint (filter-not assigned-name? cnames) - ;; pattern is mix of values and boxed symbols (indicating variables to persist) - ;; use boxes here as cheap way to distinguish id symbols from value symbols - (let ([reduce-arity-pattern (for/list ([cname (in-list cnames)]) - (if (assigned-name? cname) - (first (csp-domain prob cname)) - (box cname)))]) - (reduce-function-arity proc reduce-arity-pattern)))] - [else const]))))) + ((csp?) ((or/c #false natural?)) . ->* . csp?) + (define assigned? (curry assigned-name? prob)) + (define (partially-assigned? constraint) + (ormap assigned? (constraint-names constraint))) + (make-csp (vars prob) + (for/list ([const (in-constraints prob)]) + (cond + ;; no point reducing 2-arity functions because they will be consumed by forward checking + [(and (or (not minimum-arity) (<= minimum-arity (constraint-arity const))) + (partially-assigned? const)) + (match-define (constraint cnames proc) const) + ;; pattern is mix of values and boxed symbols (indicating variables to persist) + ;; use boxes here as cheap way to distinguish id symbols from value symbols + (define reduce-arity-pattern (for/list ([cname (in-list cnames)]) + (if (assigned? cname) + (first (find-domain prob cname)) + (box cname)))) + (constraint (filter-not assigned? cnames) + (reduce-function-arity proc reduce-arity-pattern))] + [else const])))) (define nassns 0) (define (reset-assns!) (set! nassns 0)) +(define nfchecks 0) + +(define (reset-nfcs!) (set! nfchecks 0)) + (define/contract (assign-val prob name val) (csp? name? any/c . -> . csp?) (when-debug (set! nassns (add1 nassns))) (make-csp - (for/list ([var (vars prob)]) - (if (eq? name (variable-name var)) + (for/list ([vr (vars prob)]) + (if (eq? name (var-name vr)) (assigned-var name (list val)) - var)) + vr)) (constraints prob))) (define/contract (unassigned-vars prob) - (csp? . -> . (listof (and/c variable? (not/c assigned-var?)))) + (csp? . -> . (listof (and/c var? (not/c assigned-var?)))) (filter-not assigned-var? (vars prob))) (define/contract (first-unassigned-variable csp) - (csp? . -> . (or/c #false (and/c variable? (not/c assigned-var?)))) + (csp? . -> . (or/c #false (and/c var? (not/c assigned-var?)))) (match (unassigned-vars csp) [(? empty?) #false] - [(cons x _) x])) + [xs (first xs)])) (define/contract (minimum-remaining-values prob) - (csp? . -> . (or/c #false (and/c variable? (not/c assigned-var?)))) + (csp? . -> . (or/c #false (and/c var? (not/c assigned-var?)))) (match (unassigned-vars prob) [(? empty?) #false] - [xs (argmin (λ (var) (length (variable-domain var))) xs)])) + [xs (argmin (λ (var) (length (domain var))) xs)])) (define mrv minimum-remaining-values) (define/contract (var-degree prob var) - (csp? variable? . -> . exact-nonnegative-integer?) + (csp? var? . -> . natural?) (for/sum ([const (in-constraints prob)] - #:when (memq (variable-name var) (constraint-names const))) + #:when (memq (var-name var) (constraint-names const))) 1)) -(define/contract (blended-variable-selector prob) - (csp? . -> . (or/c #false (and/c variable? (not/c assigned-var?)))) - (define uvars (unassigned-vars prob)) - (cond - [(empty? uvars) #false] - [(findf singleton-var? uvars)] - [else (first (let* ([uvars-by-mrv (sort uvars < #:key (λ (var) (length (variable-domain var))))] - [uvars-by-degree (sort uvars-by-mrv > #:key (λ (var) (var-degree prob var)))]) - uvars-by-degree))])) - -(define/contract (remaining-values var) - (variable? . -> . exact-nonnegative-integer?) - (length (variable-domain var))) +(define/contract (domain-length var) + (var? . -> . natural?) + (length (domain var))) (define/contract (mrv-degree-hybrid prob) - (csp? . -> . (or/c #f variable?)) - (define uvars (unassigned-vars prob)) - (cond - [(empty? uvars) #false] - [else + (csp? . -> . (or/c #f var?)) + (match (unassigned-vars prob) + [(? empty?) #false] + [uvars ;; minimum remaining values (MRV) rule - (define mrv-arg (argmin remaining-values uvars)) - (match (filter (λ (var) (= (remaining-values mrv-arg) (remaining-values var))) uvars) + (define mrv-arg (argmin domain-length uvars)) + (match (filter (λ (var) (= (domain-length mrv-arg) (domain-length var))) uvars) [(list winning-uvar) winning-uvar] [(list mrv-uvars ...) ;; use degree as tiebreaker for mrv (define degrees (map (λ (var) (var-degree prob var)) mrv-uvars)) (define max-degree (apply max degrees)) ;; use random tiebreaker for degree - (random-pick (for/list ([var (in-list mrv-uvars)] + (random-pick (for/list ([uv (in-list mrv-uvars)] [degree (in-list degrees)] #:when (= max-degree degree)) - var))])])) + uv))])])) (define first-domain-value values) @@ -277,44 +270,40 @@ (memq name cnames)))) const)) -(define (binary-constraint? const) - (= 2 (constraint-arity const))) +(define (two-arity? const) (= 2 (constraint-arity const))) (define (constraint-relates? const name) (memq name (constraint-names const))) -(define nfchecks 0) -(define (reset-nfcs!) (set! nfchecks 0)) - (define/contract (forward-check prob ref-name) (csp? name? . -> . csp?) - (define aval (first (csp-domain prob ref-name))) - (define (check-var var) - (match var + (define aval (first (find-domain prob ref-name))) + (define (check-var v) + (match v ;; don't check against assigned vars, or the reference var ;; (which is probably assigned but maybe not) - [(? (λ (x) (or (assigned-var? x) (eq? (variable-name x) ref-name)))) var] - [(variable name vals) + [(? (λ (x) (or (assigned-var? x) (eq? (var-name x) ref-name)))) v] + [(var name vals) (match ((constraints prob) . relating-only . (list ref-name name)) - [(? empty?) var] + [(? empty?) v] [constraints (define new-vals (for/list ([val (in-list vals)] - #:when (for/and ([constraint (in-list constraints)]) - (let ([proc (constraint-proc constraint)]) - (if (eq? name (first (constraint-names constraint))) + #:when (for/and ([const (in-list constraints)]) + (let ([proc (constraint-proc const)]) + (if (eq? name (first (constraint-names const))) (proc val aval) (proc aval val))))) val)) - (checked-var name new-vals (cons ref-name (if (checked-var? var) - (checked-var-past var) - null)))])])) + (checked-variable name new-vals (cons ref-name (match v + [(checked-variable _ _ history) history] + [else null])))])])) (define checked-vars (map check-var (vars prob))) (when-debug (set! nfchecks (+ (length checked-vars) nchecks))) - ;; conflict-set will be empty if there are no empty domains - (define conflict-set (for*/list ([var (in-list checked-vars)] - #:when (empty? (variable-domain var)) - [name (in-list (checked-var-past var))]) + ;; conflict-set will be empty if there are no empty domains (as we would hope) + (define conflict-set (for*/list ([cv (in-list checked-vars)] + #:when (empty? (domain cv)) + [name (in-list (history cv))]) name)) ;; for conflict-directed backjumping it's essential to forward-check ALL vars ;; (even after an empty domain is generated) and combine their conflicts @@ -327,43 +316,42 @@ ;; (they have no further use) (define nonsingleton-constraints (for/list ([const (in-constraints prob)] - #:unless (and - (binary-constraint? const) - (constraint-relates? const ref-name) - (let ([other-name (first (remq ref-name (constraint-names const)))]) - (singleton-var? (csp-var prob other-name))))) + #:unless (and (two-arity? const) + (constraint-relates? const ref-name) + (let ([other-name (first (remq ref-name (constraint-names const)))]) + (singleton-var? (find-var prob other-name))))) const)) (make-csp checked-vars nonsingleton-constraints)) -(define/contract (constraint-checkable? c names) +(define/contract (constraint-checkable? const names) (constraint? (listof name?) . -> . any/c) ;; constraint is checkable if all constraint names ;; are in target list of names. - (for/and ([cname (in-list (constraint-names c))]) + (for/and ([cname (in-list (constraint-names const))]) (memq cname names))) (define/contract (constraint-arity const) - (constraint? . -> . exact-nonnegative-integer?) + (constraint? . -> . natural?) (length (constraint-names const))) (define (singleton-var? var) - (= 1 (length (variable-domain var)))) + (= 1 (domain-length var))) (define nchecks 0) (define (reset-nchecks!) (set! nchecks 0)) (define/contract (check-constraints prob [mandatory-names #f] #:conflicts [conflict-count? #f]) - ((csp?) ((listof name?) #:conflicts boolean?) . ->* . (or/c csp? exact-nonnegative-integer?)) + ((csp?) ((listof name?) #:conflicts boolean?) . ->* . (or/c csp? natural?)) ;; this time, we're not limited to assigned variables ;; (that is, vars that have been deliberately assigned in the backtrack process thus far) ;; we also want to use "singleton" vars (that is, vars that have been reduced to a single domain value by forward checking) - (define singleton-varnames (for/list ([var (in-vars prob)] - #:when (singleton-var? var)) - (variable-name var))) + (define singleton-varnames (for/list ([vr (in-vars prob)] + #:when (singleton-var? vr)) + (var-name vr))) (define-values (checkable-consts other-consts) - (partition (λ (c) (and (constraint-checkable? c singleton-varnames) - (or (not mandatory-names) - (for/and ([name (in-list mandatory-names)]) - (constraint-relates? c name))))) + (partition (λ (const) (and (constraint-checkable? const singleton-varnames) + (or (not mandatory-names) + (for/and ([name (in-list mandatory-names)]) + (constraint-relates? const name))))) (constraints prob))) (cond [conflict-count? @@ -374,7 +362,7 @@ (when-debug (set! nchecks (+ conflict-count nchecks))) conflict-count] [else - (for ([(constraint idx) (in-indexed (sort checkable-consts < #:key constraint-arity))] + (for ([(constraint idx) (in-indexed checkable-consts)] #:unless (constraint prob)) (when-debug (set! nchecks (+ (add1 idx) nchecks))) (backtrack!)) @@ -385,16 +373,16 @@ (csp? . -> . csp?) ;; todo: why does this function slow down searches? (make-csp - (for/list ([var (in-vars prob)]) - (match-define (variable name vals) var) + (for/list ([vr (in-vars prob)]) + (match-define (var name vals) vr) (define procs (for*/list ([const (in-constraints prob)] [cnames (in-value (constraint-names const))] #:when (and (= 1 (length cnames)) (eq? name (car cnames)))) (constraint-proc const))) - (variable name - (for*/fold ([vals vals]) - ([proc (in-list procs)]) - (filter proc vals)))) + (var name + (for*/fold ([vals vals]) + ([proc (in-list procs)]) + (filter proc vals)))) (constraints prob))) (define/contract (backtracking-solver @@ -408,15 +396,15 @@ (let loop ([prob prob]) (match (select-unassigned-variable prob) [#false (yield prob)] - [(variable name domain) + [(var name domain) (define (wants-backtrack? exn) - (and ($backtrack? exn) (or (let ([btns ($backtrack-names exn)]) - (or (empty? btns) (memq name btns)))))) + (and (backtrack? exn) (or (let ([btns (backtrack-names exn)]) + (or (empty? btns) (memq name btns)))))) (for/fold ([conflicts null] #:result (void)) ([val (in-list (order-domain-values domain))]) (with-handlers ([wants-backtrack? - (λ (bt) (append conflicts (remq name ($backtrack-names bt))))]) + (λ (bt) (append conflicts (remq name (backtrack-names bt))))]) (let* ([prob (assign-val prob name val)] ;; reduce constraints before inference, ;; to create more forward-checkable (binary) constraints @@ -432,7 +420,7 @@ (define (assign-random-vals prob) (for/fold ([new-csp prob]) ([name (in-variable-names prob)]) - (assign-val new-csp name (random-pick (csp-domain prob name))))) + (assign-val new-csp name (random-pick (find-domain prob name))))) (define (make-min-conflcts-thread prob-start thread-count max-steps [main-thread (current-thread)]) (thread @@ -446,13 +434,13 @@ [(? empty?) (thread-send main-thread prob) (loop)] [names (define name (random-pick names)) - (define val (min-conflicts-value prob name (csp-domain prob-start name))) + (define val (min-conflicts-value prob name (find-domain prob-start name))) (assign-val prob name val)])))))) (define/contract (min-conflicts-solver prob [max-steps 100]) ((csp?) (integer?) . ->* . generator?) (generator () - (for ([thread-count 4]) ; todo: what is ideal thread count? + (for ([thread-count (or (current-thread-count) 1)]) ; todo: what is ideal thread count? (make-min-conflcts-thread prob thread-count max-steps)) (for ([i (in-naturals)]) (yield (thread-receive))))) @@ -461,9 +449,9 @@ (procedure? (listof any/c) . -> . any/c) (define-values (sample candidates) (split-at xs (inexact->exact (floor (* .458 (length xs)))))) (define threshold (argmin proc sample)) - (or (for/first ([c (in-list candidates)] - #:when (<= (proc c) threshold)) - c) + (or (for/first ([candidate (in-list candidates)] + #:when (<= (proc candidate) threshold)) + candidate) (last candidates))) (define/contract (conflicted-variable-names prob) @@ -479,13 +467,13 @@ (define vals-by-conflict (sort vals < #:key (λ (val) (nconflicts prob name val)) #:cache-keys? #true)) (for/first ([val (in-list vals-by-conflict)] - #:unless (equal? val (first (csp-domain prob name)))) ;; but change the value + #:unless (equal? val (first (find-domain prob name)))) ;; but change the value val)) (define no-value-sig (gensym)) (define/contract (nconflicts prob name [val no-value-sig]) - ((csp? name?) (any/c) . ->* . exact-nonnegative-integer?) + ((csp? name?) (any/c) . ->* . natural?) ;; How many conflicts var: val assignment has with other variables. (check-constraints (if (eq? val no-value-sig) prob @@ -493,14 +481,14 @@ (define/contract (csp->assocs prob) (csp? . -> . (listof (cons/c name? any/c))) - (for/list ([var (in-vars prob)]) - (match var - [(variable name (list val)) (cons name val)]))) + (for/list ([vr (in-vars prob)]) + (match vr + [(var name (list val)) (cons name val)]))) (define/contract (combine-csps probs) ((listof csp?) . -> . csp?) (make-csp - (apply append (map csp-vars probs)) + (apply append (map vars probs)) (apply append (map csp-constraints probs)))) (define/contract (make-cartesian-generator solgens) @@ -518,9 +506,9 @@ (define/contract (extract-subcsp prob names) (csp? (listof name?) . -> . csp?) (make-csp - (for/list ([var (in-vars prob)] - #:when (memq (variable-name var) names)) - var) + (for/list ([vr (in-vars prob)] + #:when (memq (var-name vr) names)) + vr) (for/list ([const (in-constraints prob)] #:when (for/and ([cname (in-list (constraint-names const))]) (memq cname names))) @@ -530,7 +518,7 @@ #:finish-proc [finish-proc csp->assocs] #:solver [solver (or (current-solver) backtracking-solver)] #:limit [max-solutions +inf.0]) - ((csp?) (#:finish-proc procedure? #:solver procedure? #:limit exact-nonnegative-integer?) + ((csp?) (#:finish-proc procedure? #:solver procedure? #:limit natural?) . ->* . (listof any/c)) (when-debug (reset-assns!) (reset-nfcs!) (reset-nchecks!)) @@ -548,7 +536,7 @@ #:finish-proc [finish-proc csp->assocs] #:solver [solver (or (current-solver) backtracking-solver)] #:limit [max-solutions 1]) - ((csp?) (#:finish-proc procedure? #:solver procedure? #:limit exact-nonnegative-integer?) + ((csp?) (#:finish-proc procedure? #:solver procedure? #:limit natural?) . ->* . (or/c #false any/c)) (match (solve* prob #:finish-proc finish-proc #:solver solver #:limit max-solutions) [(list solution) solution]