From a427cb0ee48d1a8d7637e7c6a8888d95d97895fc Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 25 Oct 2018 15:36:00 -0700 Subject: [PATCH] changes --- csp/csp/hacs-test-sudoku.rkt | 104 ++++++++++++++++++++++++++++++++++ csp/csp/hacs.rkt | 93 ++++++++++++++++-------------- csp/csp/scribblings/csp.scrbl | 2 + 3 files changed, 157 insertions(+), 42 deletions(-) create mode 100644 csp/csp/hacs-test-sudoku.rkt diff --git a/csp/csp/hacs-test-sudoku.rkt b/csp/csp/hacs-test-sudoku.rkt new file mode 100644 index 00000000..8031e57f --- /dev/null +++ b/csp/csp/hacs-test-sudoku.rkt @@ -0,0 +1,104 @@ +#lang debug br +(require sugar/debug "hacs.rkt") + +(define names (for/list ([i (in-range 81)]) + (string->symbol (format "c~a" i)))) + +(define (make-sudoku) + (define sudoku (make-csp)) + (add-vars! sudoku names (range 1 10)) + + (define (not= . xs) (= (length xs) (length (remove-duplicates xs =)))) + + (for ([i (in-range 9)]) + (define row-cells (for/list ([(name idx) (in-indexed names)] + #:when (= (quotient idx 9) i)) + name)) + (add-pairwise-constraint! sudoku not= row-cells) + (define col-cells (for/list ([(name idx) (in-indexed names)] + #:when (= (remainder idx 9) i)) + name)) + (add-pairwise-constraint! sudoku not= col-cells)) + + (for ([i '(0 3 6 27 30 33 54 57 60)]) + (define box-cells (for/list ([j '(0 1 2 9 10 11 18 19 20)]) + (string->symbol (format "c~a" (+ i j))))) + (add-pairwise-constraint! sudoku not= box-cells)) + + sudoku) + +(require racket/sequence) +(define (print-grid sol) + (displayln (string-join (map ~a (for/list ([row (in-slice 9 (csp->assocs sol))]) + (map cdr row))) "\n"))) + +(define (board . strs) + (define sudoku (make-sudoku)) + (define vals + (for*/list ([str strs] + [c (in-port read-char (open-input-string str))] + #:unless (memv c '(#\- #\|))) + (match (string c) + [(? string->number num) (string->number num)] + [else #f]))) + (for ([name names] + [val vals] + #:when val) + (add-constraint! sudoku (curry = val) (list name) (string->symbol (format "is-~a" val)))) + sudoku) + +;; http://jeapostrophe.github.io/2013-10-23-sudoku-post.html + +(define b1 + (board + "53 | 7 | " + "6 |195| " + " 98| | 6 " + "-----------" + "8 | 6 | 3" + "4 |8 3| 1" + "7 | 2 | 6" + "-----------" + " 6 | |28 " + " |419| 5" + " | 8 | 79")) + +;; "Hard" example +(define b2 + (board + " 7 | 2 | 5" + " 9| 87| 3" + " 6 | | 4 " + "-----------" + " | 6 | 17" + "9 4| |8 6" + "71 | 5 | " + "-----------" + " 9 | | 8 " + "5 |21 |4 " + "4 | 9 | 6 ")) + +;; "Evil" example +(define b3 + (board + " 8| | 45" + " | 8 |9 " + " 2|4 | " + "-----------" + "5 | 1|76 " + " 1 | 7 | 8 " + " 79|5 | 1" + "-----------" + " | 7|4 " + " 7| 6 | " + "65 | |3 ")) + +(current-inference forward-check) +(current-select-variable mrv-degree-hybrid) +(current-order-values shuffle) +(current-random #true) +(current-node-consistency #t) +(current-arity-reduction #t) +(time-avg 10 (solve b1 #:finish-proc print-grid)) +(time-avg 10 (solve b2 #:finish-proc print-grid)) +(time-avg 10 (solve b3 #:finish-proc print-grid)) \ No newline at end of file diff --git a/csp/csp/hacs.rkt b/csp/csp/hacs.rkt index 9ccaef66..268301c3 100644 --- a/csp/csp/hacs.rkt +++ b/csp/csp/hacs.rkt @@ -57,7 +57,7 @@ (apply add-edge! gr edge) gr)) -(struct var (name domain) #:transparent) +(struct var (name domain) #:transparent #:mutable) (define domain var-domain) (struct checked-variable var (history) #:transparent) @@ -246,13 +246,14 @@ (define/contract (state-count csp) (csp? . -> . natural?) - (for/product ([var (in-vars csp)]) - (domain-length var))) + (for/product ([vr (in-vars csp)]) + (domain-length vr))) (define/contract (mrv-degree-hybrid prob) (csp? . -> . (or/c #f var?)) (match (unassigned-vars prob) [(? empty?) #false] + [(cons (? singleton-var? uvar) _) uvar] [uvars ;; minimum remaining values (MRV) rule (define mrv-arg (argmin domain-length uvars)) @@ -476,6 +477,12 @@ (define (history->constraint hst) (constraint (map car hst) (make-hist-proc hst))) +(define/contract (assign-singletons prob) + (csp? . -> . csp?) + (for/fold ([prob prob]) + ([vr (in-vars prob)] + #:when (singleton-var? vr)) + (assign-val prob (var-name vr) (first (var-domain vr))))) (define/contract (backtracking-solver prob @@ -488,45 +495,47 @@ (define reduce-arity-proc (if (current-arity-reduction) reduce-constraint-arity values)) (define learned-constraints null) (define learning? (current-learning)) - (let loop ([prob ((if (current-node-consistency) make-nodes-consistent values) prob)]) - (match (select-unassigned-variable prob) - [#false (yield prob)] - [(var name domain) - (define (wants-backtrack? exn) - (and (backtrack? exn) (or (let ([bths (backtrack-histories exn)]) - (or (empty? bths) (for*/or ([bth bths] - [rec bth]) - (eq? name (car rec)))))))) - (for/fold ([conflicts null] - #:result (void)) - ([val (in-list (order-domain-values domain))]) - (with-handlers ([wants-backtrack? - (λ (bt) - (define bths (backtrack-histories bt)) - (when learning? - (set! learned-constraints (append - (map history->constraint (filter (λ (bth) (<= 2 (length bth) 4)) bths)) - learned-constraints))) - (append conflicts (remq name (remove-duplicates - (for*/list ([bth bths] - [rec bth]) - (car rec)) eq?))))]) - (let* ([prob (assign-val prob name val)] - [prob (if learning? - (and (for ([lc learned-constraints] - #:when (for/and ([cname (constraint-names lc)]) - (memq cname (map var-name (filter assigned-var? (vars prob)))))) - (unless (lc prob) - (println 'boing) - (backtrack!))) prob) - prob)] - ;; reduce constraints before inference, - ;; to create more forward-checkable (binary) constraints - [prob (reduce-arity-proc prob)] - [prob (inference prob name)] - [prob (check-constraints prob)]) - (loop prob))) - conflicts)])))) + (let* ([prob ((if (current-node-consistency) make-nodes-consistent values) prob)] + [prob (assign-singletons prob)]) + (let loop ([prob prob]) + (match (select-unassigned-variable prob) + [#false (yield prob)] + [(var name domain) + (define (wants-backtrack? exn) + (and (backtrack? exn) (or (let ([bths (backtrack-histories exn)]) + (or (empty? bths) (for*/or ([bth bths] + [rec bth]) + (eq? name (car rec)))))))) + (for/fold ([conflicts null] + #:result (void)) + ([val (in-list (order-domain-values domain))]) + (with-handlers ([wants-backtrack? + (λ (bt) + (define bths (backtrack-histories bt)) + (when learning? + (set! learned-constraints (append + (map history->constraint (filter (λ (bth) (<= 2 (length bth) 4)) bths)) + learned-constraints))) + (append conflicts (remq name (remove-duplicates + (for*/list ([bth bths] + [rec bth]) + (car rec)) eq?))))]) + (let* ([prob (assign-val prob name val)] + [prob (if learning? + (and (for ([lc learned-constraints] + #:when (for/and ([cname (constraint-names lc)]) + (memq cname (map var-name (filter assigned-var? (vars prob)))))) + (unless (lc prob) + (println 'boing) + (backtrack!))) prob) + prob)] + ;; reduce constraints before inference, + ;; to create more forward-checkable (binary) constraints + [prob (reduce-arity-proc prob)] + [prob (inference prob name)] + [prob (check-constraints prob)]) + (loop prob))) + conflicts)]))))) (define (random-pick xs) (list-ref xs (random (length xs)))) diff --git a/csp/csp/scribblings/csp.scrbl b/csp/csp/scribblings/csp.scrbl index f258b80f..2f14be48 100644 --- a/csp/csp/scribblings/csp.scrbl +++ b/csp/csp/scribblings/csp.scrbl @@ -136,6 +136,8 @@ Of course, when we use ordinary @racket[solve], we don't know how many assignmen Disappointing but accurate. + + @section{Making & solving CSPs}