From 62c11e167625e595a8a7ed711c53d0eb0a50340a Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 20 Oct 2018 18:08:13 -0700 Subject: [PATCH] min-con --- csp/aima-queens.rkt | 25 ++++++++++++ csp/aima.rkt | 6 ++- csp/hacs-test-workbench.rkt | 25 +++++++++++- csp/hacs-test.rkt | 6 +-- csp/hacs.rkt | 81 ++++++++++++++++++++++++++++++------- 5 files changed, 120 insertions(+), 23 deletions(-) create mode 100644 csp/aima-queens.rkt diff --git a/csp/aima-queens.rkt b/csp/aima-queens.rkt new file mode 100644 index 00000000..4f29fe56 --- /dev/null +++ b/csp/aima-queens.rkt @@ -0,0 +1,25 @@ +#lang br +(require "aima.rkt" sugar/debug) + + +;; queens problem +;; place queens on chessboard so they do not intersect +(define qs (for/list ([q 8]) (string->symbol (format "q~a" q)))) +(define rows (range (length qs))) +(define vds (for/list ([q qs]) + ($vd q (range (length qs))))) +(define (q-col q) (string->number (string-trim (symbol->string q) "q"))) +(define cs (for*/list ([qs (in-combinations qs 2)]) + (match-define (list qa qb) qs) + (match-define (list qa-col qb-col) (map q-col qs)) + ($constraint + (list qa qb) + (λ (qa-row qb-row) + (and + (not (= (abs (- qa-row qb-row)) (abs (- qa-col qb-col)))) ; same diagonal? + (not (= qa-row qb-row))))))) + +(define queens (make-csp vds cs)) + +(current-solver min-conflicts) +(time-named (solve queens)) \ No newline at end of file diff --git a/csp/aima.rkt b/csp/aima.rkt index 042a76be..05346496 100644 --- a/csp/aima.rkt +++ b/csp/aima.rkt @@ -370,7 +370,8 @@ ;; ______________________________________________________________________________ ;; Min-conflicts hillclimbing search for CSPs -(define (min_conflicts csp [max_steps (expt 10 5)]) +(require sugar/debug) +(define (min-conflicts csp [max_steps (expt 10 5)]) (($csp?) (integer?) . ->* . generator?) ;; Solve a CSP by stochastic hillclimbing on the number of conflicts. ;; Generate a complete assignment for all variables (probably with conflicts) @@ -384,6 +385,7 @@ (for ([i (in-range max_steps)]) (define conflicted (conflicted_vars csp current)) (when (empty? conflicted) + (report i) (yield current)) (define var (first ((if (current-shuffle) shuffle values) conflicted))) (define val (min_conflicts_value csp var current)) @@ -527,7 +529,7 @@ (set-$csp-curr_domains! csp #f) (parameterize ([current-shuffle #f] - [current-solver min_conflicts]) + [current-solver min-conflicts]) (check-equal? (solve csp) (make-hasheq '((nsw . red) (nt . red) (q . green) (sa . blue) (t . red) (v . green) (wa . green)))) diff --git a/csp/hacs-test-workbench.rkt b/csp/hacs-test-workbench.rkt index dad7dcf2..32fa1f05 100644 --- a/csp/hacs-test-workbench.rkt +++ b/csp/hacs-test-workbench.rkt @@ -1,7 +1,28 @@ #lang debug racket -(require sugar "hacs.rkt") +(require sugar/debug "hacs.rkt") (current-inference forward-check) (current-select-variable mrv) (current-order-values shuffle) -(current-shuffle #true) \ No newline at end of file +(current-shuffle #true) + +;; queens problem +;; place queens on chessboard so they do not intersect +(define queens (make-csp)) +(define qs (for/list ([q 10]) (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)) +(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 531a2b45..42da51e8 100644 --- a/csp/hacs-test.rkt +++ b/csp/hacs-test.rkt @@ -158,10 +158,6 @@ (check-equal? 92 (length (time-named (solve* queens)))) -#;(parameterize ([current-solver min-conflicts]) - (solve queens)) - - #| # There are no tricks, just pure logic, so good luck and don't give up. # @@ -298,4 +294,4 @@ (time-avg n (void (solve smm))) (time-avg n (void (solve* queens))) (time-avg n (void (solve zebra))))) - + \ No newline at end of file diff --git a/csp/hacs.rkt b/csp/hacs.rkt index dc41594f..4b0acbea 100644 --- a/csp/hacs.rkt +++ b/csp/hacs.rkt @@ -1,5 +1,5 @@ #lang debug racket -(require racket/generator graph) +(require racket/generator graph sugar/debug) (provide (all-defined-out)) (define-syntax when-debug @@ -345,8 +345,8 @@ (define nchecks 0) (define (reset-nchecks!) (set! nchecks 0)) -(define/contract (check-constraints csp) - (csp? . -> . csp?) +(define/contract (check-constraints csp [mandatory-names #f] #:conflicts [conflict-count? #f]) + ((csp?) ((listof name?) #:conflicts boolean?) . ->* . (or/c csp? exact-nonnegative-integer?)) ;; 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) @@ -354,13 +354,24 @@ #:when (singleton-var? var)) (var-name var))) (define-values (checkable-constraints other-constraints) - (partition (λ (c) (constraint-checkable? c singleton-varnames)) (constraints csp))) - (for ([(constraint idx) (in-indexed (sort checkable-constraints < #:key constraint-arity))] - #:unless (constraint csp)) - (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)) + (partition (λ (c) (and (constraint-checkable? c singleton-varnames) + (if mandatory-names + (for/and ([name (in-list mandatory-names)]) + (constraint-relates? c name)) + #true))) (constraints csp))) + (cond + [conflict-count? (define conflict-count + (for/sum ([constraint (in-list checkable-constraints)] + #:unless (constraint csp)) + 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!)) + ;; discard checked constraints, since they have no further reason to live + (make-csp (vars csp) other-constraints)])) (define/contract (make-nodes-consistent csp) (csp? . -> . csp?) @@ -407,7 +418,49 @@ (loop csp))) conflicts)])))) -;; todo: min-conflicts solver + +(define/contract (min-conflicts csp [max-steps (expt 10 3)]) + (($csp?) (integer?) . ->* . generator?) + ;; Solve a CSP by stochastic hillclimbing on the number of conflicts. + (generator () + (let loop ([csp0 csp]) + ;; 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)))))) + ;; 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) (report i 'steps-taken) (yield csp))] + [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)))) + +(define/contract (conflicted-var-names csp) + ($csp? . -> . (listof name?)) + ;; Return a list of variables in current assignment that are conflicted + (for/list ([var (in-vars csp)] + #:when (positive? (nconflicts csp (var-name var)))) + (var-name var))) + +(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-random-tie (λ (val) (nconflicts csp name val)) vals)) + +(define no-value-sig (gensym)) + +(define/contract (nconflicts csp name [val no-value-sig]) + (($csp? name?) (any/c) . ->* . exact-nonnegative-integer?) + ;; How many conflicts var: val assignment has with other variables. + (check-constraints (if (eq? val no-value-sig) + csp + (assign-val csp name val)) (list name) #:conflicts #t)) (define/contract (csp->assocs csp) (csp? . -> . (listof (cons/c name? any/c))) @@ -418,8 +471,8 @@ (define/contract (solve* csp #:finish-proc [finish-proc csp->assocs] #:solver [solver (or (current-solver) backtracking-solver)] - #:count [max-solutions +inf.0]) - ((csp?) (#:finish-proc procedure? #:solver procedure? #:count integer?) . ->* . (listof any/c)) + #:limit [max-solutions +inf.0]) + ((csp?) (#:finish-proc procedure? #:solver procedure? #:limit integer?) . ->* . (listof any/c)) (when-debug (reset-assns!) (reset-nfcs!) @@ -432,7 +485,7 @@ #:finish-proc [finish-proc csp->assocs] #:solver [solver (or (current-solver) backtracking-solver)]) ((csp?) (#:finish-proc procedure? #:solver procedure?) . ->* . (or/c #false any/c)) - (match (solve* csp #:finish-proc finish-proc #:solver solver #:count 1) + (match (solve* csp #:finish-proc finish-proc #:solver solver #:limit 1) [(list solution) solution] [else #false]))