diff --git a/csp/hacs-test-workbench.rkt b/csp/hacs-test-workbench.rkt index 2c39acd7..55faea1c 100644 --- a/csp/hacs-test-workbench.rkt +++ b/csp/hacs-test-workbench.rkt @@ -4,25 +4,28 @@ (current-inference forward-check) (current-select-variable mrv) (current-order-values shuffle) -(current-shuffle #true) +(current-random #true) ;; queens problem ;; place queens on chessboard so they do not intersect -(define queens (make-csp)) -(define qs (for/list ([q 8]) (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) - (nor - (= (abs (- qa-row qb-row)) (abs (- qa-col qb-col))) ; same diagonal? - (= qa-row qb-row))) ; same row? - (list qa qb))) -#;(time-named (solve queens)) +(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) + (nor + (= (abs (- qa-row qb-row)) (abs (- qa-col qb-col))) ; same diagonal? + (= qa-row qb-row))) ; same row? + (list qa qb))) + +(time-avg 10 (solve queens)) (parameterize ([current-solver min-conflicts]) (time-named (solve queens))) \ No newline at end of file diff --git a/csp/hacs-test.rkt b/csp/hacs-test.rkt index 42da51e8..4c3511b5 100644 --- a/csp/hacs-test.rkt +++ b/csp/hacs-test.rkt @@ -4,7 +4,7 @@ (current-inference forward-check) (current-select-variable mrv-degree-hybrid) (current-order-values shuffle) -(current-shuffle #true) +(current-random #true) (check-equal? (first-unassigned-variable ($csp (list ($var 'a (range 3)) ($var 'b (range 3))) null)) ($var 'a (range 3))) @@ -278,7 +278,7 @@ (apply map list (slice-at x 5))) (check-equal? (parameterize ([current-select-variable mrv] - [current-shuffle #f]) + [current-random #f]) (finish (time-named (solve zebra)))) '(((nationality-0 . norwegian) (color-0 . yellow) (drink-0 . water) (smoke-0 . kools) (pet-0 . foxes)) ((nationality-1 . ukrainian) (color-1 . blue) (drink-1 . tea) (smoke-1 . chesterfields) (pet-1 . horses)) diff --git a/csp/hacs.rkt b/csp/hacs.rkt index 999983c3..36042e0b 100644 --- a/csp/hacs.rkt +++ b/csp/hacs.rkt @@ -16,7 +16,7 @@ (if (null? argss) (yield (reverse acc)) (for ([arg (in-list (car argss))]) - (loop (cdr argss) (cons arg acc)))))))) + (loop (cdr argss) (cons arg acc)))))))) (struct $csp (vars constraints @@ -37,7 +37,7 @@ (raise-argument-error '$constraint-proc "$csp" csp)) ;; apply proc in many-to-many style (for/and ([args (in-cartesian (map (λ (cname) ($csp-vals csp cname)) ($constraint-names constraint)))]) - (apply ($constraint-proc constraint) args)))) + (apply ($constraint-proc constraint) args)))) (define (make-constraint [names null] [proc values]) ($constraint names proc)) @@ -92,11 +92,11 @@ ((csp? procedure? (listof (listof name?))) ((or/c #false name?)) . ->* . void?) (set-$csp-constraints! csp (append (constraints csp) (for/list ([names (in-list namess)]) - (for ([name (in-list names)]) - (check-name-in-csp! 'add-constraints! csp name)) - (make-constraint names (if proc-name - (procedure-rename proc proc-name) - proc)))))) + (for ([name (in-list names)]) + (check-name-in-csp! 'add-constraints! csp name)) + (make-constraint names (if proc-name + (procedure-rename proc proc-name) + proc)))))) (define/contract (add-pairwise-constraint! csp proc var-names [proc-name #false]) ((csp? procedure? (listof name?)) (name?) . ->* . void?) @@ -117,7 +117,7 @@ (define current-order-values (make-parameter #f)) (define current-inference (make-parameter #f)) (define current-solver (make-parameter #f)) -(define current-shuffle (make-parameter #t)) +(define current-random (make-parameter #t)) (define/contract (check-name-in-csp! caller csp name) (symbol? csp? name? . -> . void?) @@ -130,7 +130,7 @@ (check-name-in-csp! 'csp-var csp name) (for/first ([var (in-vars csp)] #:when (eq? name (var-name var))) - var)) + var)) (define/contract ($csp-vals csp name) (csp? name? . -> . (listof any/c)) @@ -143,7 +143,7 @@ (csp? name? . -> . any/c) (for/or ([var (in-vars csp)] #:when (assigned-var? var)) - (eq? name (var-name var)))) + (eq? name (var-name var)))) (define (reduce-function-arity proc pattern) (unless (match (procedure-arity proc) @@ -174,19 +174,19 @@ (ormap assigned-name? ($constraint-names constraint))) (make-csp (vars csp) (for/list ([constraint (in-constraints csp)]) - (cond - [(and (if minimum-arity (<= minimum-arity (constraint-arity constraint)) #true) - (partially-assigned? constraint)) - (match-define ($constraint cnames proc) constraint) - ($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-vals csp cname)) - (box cname)))]) - (reduce-function-arity proc reduce-arity-pattern)))] - [else constraint]))))) + (cond + [(and (if minimum-arity (<= minimum-arity (constraint-arity constraint)) #true) + (partially-assigned? constraint)) + (match-define ($constraint cnames proc) constraint) + ($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-vals csp cname)) + (box cname)))]) + (reduce-function-arity proc reduce-arity-pattern)))] + [else constraint]))))) (define nassns 0) (define (reset-assns!) (set! nassns 0)) @@ -195,9 +195,9 @@ (when-debug (set! nassns (add1 nassns))) (make-csp (for/list ([var (vars csp)]) - (if (eq? name (var-name var)) - ($avar name (list val)) - var)) + (if (eq? name (var-name var)) + ($avar name (list val)) + var)) (constraints csp))) (define/contract (unassigned-vars csp) @@ -214,7 +214,7 @@ (csp? . -> . (or/c #false (and/c $var? (not/c assigned-var?)))) (match (unassigned-vars csp) [(? empty?) #false] - [xs (argmin (λ (var) (length ($var-domain var))) (shuffle xs))])) + [xs (argmin (λ (var) (length ($var-domain var))) xs)])) (define mrv minimum-remaining-values) @@ -222,7 +222,7 @@ (csp? $var? . -> . exact-nonnegative-integer?) (for/sum ([constraint (in-constraints csp)] #:when (memq (var-name var) ($constraint-names constraint))) - 1)) + 1)) (define/contract (blended-variable-selector csp) (csp? . -> . (or/c #false (and/c $var? (not/c assigned-var?)))) @@ -252,7 +252,7 @@ ;; use degree as tiebreaker for mrv (define max-degree-arg (argmax (λ (var) (var-degree csp var)) mrv-uvars)) ;; use random tiebreaker for degree - (first (shuffle (filter (λ (var) (= (var-degree csp max-degree-arg) (var-degree csp var))) mrv-uvars)))])])) + (random-pick (filter (λ (var) (= (var-degree csp max-degree-arg) (var-degree csp var))) mrv-uvars))])])) (define first-domain-value values) @@ -264,8 +264,8 @@ [cnames (in-value ($constraint-names constraint))] #:when (and (= (length names) (length cnames)) (for/and ([name (in-list names)]) - (memq name cnames)))) - constraint)) + (memq name cnames)))) + constraint)) (define (binary-constraint? constraint) (= 2 (constraint-arity constraint))) @@ -291,11 +291,11 @@ (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))) - (proc val aval) - (proc aval val))))) - val)) + (let ([proc ($constraint-proc constraint)]) + (if (eq? name (first ($constraint-names constraint))) + (proc val aval) + (proc aval val))))) + val)) ($cvar name new-vals (cons aname (if ($cvar? var) ($cvar-past var) null)))])])) @@ -305,7 +305,7 @@ (define conflict-set (for*/list ([var (in-list checked-vars)] #:when (empty? ($var-domain var)) [name (in-list ($cvar-past var))]) - name)) + name)) ;; for conflict-directed backjumping it's essential to forward-check ALL vars ;; (even after an empty domain is generated) and combine their conflicts ;; so we can discover the *most recent past var* that could be the culprit. @@ -322,13 +322,13 @@ (constraint-relates? constraint aname) (let ([other-name (first (remq aname ($constraint-names constraint)))]) (singleton-var? (csp-var csp other-name))))) - constraint)) + constraint)) (make-csp checked-vars nonsingleton-constraints)) (define/contract (constraint-checkable? c names) ($constraint? (listof name?) . -> . any/c) (for/and ([cname (in-list ($constraint-names c))]) - (memq cname names))) + (memq cname names))) (define/contract (constraint-arity constraint) ($constraint? . -> . exact-nonnegative-integer?) @@ -346,24 +346,24 @@ ;; 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 csp)] #:when (singleton-var? var)) - (var-name var))) + (var-name var))) (define-values (checkable-constraints other-constraints) (partition (λ (c) (and (constraint-checkable? c singleton-varnames) (if mandatory-names (for/and ([name (in-list mandatory-names)]) - (constraint-relates? c name)) + (constraint-relates? c name)) #true))) (constraints csp))) (cond [conflict-count? (define conflict-count (for/sum ([constraint (in-list checkable-constraints)] #:unless (constraint csp)) - 1)) + 1)) (when-debug (set! nchecks (+ conflict-count nchecks))) conflict-count] [else (for ([(constraint idx) (in-indexed (sort checkable-constraints < #:key constraint-arity))] #:unless (constraint csp)) - (when-debug (set! nchecks (+ (add1 idx) nchecks))) - (backtrack!)) + (when-debug (set! nchecks (+ (add1 idx) nchecks))) + (backtrack!)) ;; discard checked constraints, since they have no further reason to live (make-csp (vars csp) other-constraints)])) @@ -372,15 +372,15 @@ ;; todo: why does this function slow down searches? (make-csp (for/list ([var (in-vars csp)]) - (match-define ($var name vals) var) - (define procs (for*/list ([constraint (in-constraints csp)] - [cnames (in-value ($constraint-names constraint))] - #:when (and (= 1 (length cnames)) (eq? name (car cnames)))) - ($constraint-proc constraint))) - ($var name - (for*/fold ([vals vals]) - ([proc (in-list procs)]) - (filter proc vals)))) + (match-define ($var name vals) var) + (define procs (for*/list ([constraint (in-constraints csp)] + [cnames (in-value ($constraint-names constraint))] + #:when (and (= 1 (length cnames)) (eq? name (car cnames)))) + ($constraint-proc constraint))) + ($var name + (for*/fold ([vals vals]) + ([proc (in-list procs)]) + (filter proc vals)))) (constraints csp))) (define/contract (backtracking-solver @@ -412,8 +412,10 @@ (loop csp))) conflicts)])))) +(define (random-pick xs) + (list-ref xs (random (length xs)))) -(define/contract (min-conflicts csp [max-steps 64]) +(define/contract (min-conflicts csp [max-steps 100]) (($csp?) (integer?) . ->* . generator?) ;; Solve a CSP by stochastic hillclimbing on the number of conflicts. (generator () @@ -421,31 +423,34 @@ ;; Generate a complete assignment for all variables (probably with conflicts) (define starting-assignment (for/fold ([csp csp0]) - ([var (in-vars csp0)]) - (define name (var-name var)) - (assign-val csp name (first (shuffle ($csp-vals csp0 name)))))) + ([var (in-vars csp0)]) + (define name (var-name var)) + (assign-val csp name (random-pick ($csp-vals csp0 name))))) ;; Now repeatedly choose a random conflicted variable and change it (for/fold ([csp starting-assignment]) ([i (in-range max-steps)]) (match (conflicted-var-names csp) - [(? empty?) (when (check-constraints csp) (yield csp)) (loop csp0)] - [cvar-names - (define cvar-name (first ((if (current-shuffle) shuffle values) cvar-names))) - (define val (min-conflicts-value csp cvar-name ($csp-vals csp0 cvar-name))) - (assign-val csp cvar-name val)])) - (loop csp0)))) + [(? empty?) (yield csp) (loop csp0)] + [names + (define name (random-pick names)) + (define val (min-conflicts-value csp name ($csp-vals csp0 name))) + (assign-val csp name val)]))))) (define/contract (conflicted-var-names csp) ($csp? . -> . (listof name?)) ;; Return a list of variables in current assignment that are conflicted (for/list ([name (in-var-names csp)] #:when (positive? (nconflicts csp name))) - name)) + name)) (define/contract (min-conflicts-value csp name vals) ($csp? name? (listof any/c) . -> . any/c) ;; Return the value that will give var the least number of conflicts - (argmin (λ (val) (nconflicts csp name val)) (shuffle vals))) + (define vals-by-conflict (sort vals < #:key (λ (val) (nconflicts csp name val)) + #:cache-keys? #true)) + (for/first ([val (in-list vals-by-conflict)] + #:unless (equal? val (first ($csp-vals csp name)))) + val)) (define no-value-sig (gensym)) @@ -459,8 +464,8 @@ (define/contract (csp->assocs csp) (csp? . -> . (listof (cons/c name? any/c))) (for/list ([var (in-vars csp)]) - (match var - [($var name domain) (cons name (first domain))]))) + (match var + [($var name domain) (cons name (first domain))]))) (define/contract (solve* csp #:finish-proc [finish-proc csp->assocs] @@ -473,7 +478,7 @@ (reset-nchecks!)) (for/list ([solution (in-producer (solver csp) (void))] [idx (in-range max-solutions)]) - (finish-proc solution))) + (finish-proc solution))) (define/contract (solve csp #:finish-proc [finish-proc csp->assocs]