diff --git a/csp/hacs-test.rkt b/csp/hacs-test.rkt index 99d8bfee..49b2541d 100644 --- a/csp/hacs-test.rkt +++ b/csp/hacs-test.rkt @@ -79,7 +79,7 @@ (add-constraint! quarters (λ (d q) (= 26 (+ d q))) '(dollars quarters)) (add-constraint! quarters (λ (d q) (= 17 (+ d (* 0.25 q)))) '(dollars quarters)) (check-equal? (time (solve quarters)) - '((dollars . 14) (quarters . 12))) + '((dollars . 14) (quarters . 12))) ;; xsum @@ -158,6 +158,9 @@ (check-equal? 92 (length (time (solve* queens)))) +#;(parameterize ([current-solver min-conflicts]) + (solve queens)) + #| # There are no tricks, just pure logic, so good luck and don't give up. @@ -277,10 +280,10 @@ (apply map list (slice-at x 5))) (check-equal? (parameterize ([current-select-variable mrv] - [current-shuffle #f]) - (finish (time (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)) - ((nationality-2 . englishman) (color-2 . red) (drink-2 . milk) (smoke-2 . oldgold) (pet-2 . snails)) - ((nationality-3 . japanese) (color-3 . green) (drink-3 . coffee) (smoke-3 . parliaments) (pet-3 . zebra)) - ((nationality-4 . spaniard) (color-4 . ivory) (drink-4 . orange-juice) (smoke-4 . luckystrike) (pet-4 . dogs)))) + [current-shuffle #f]) + (finish (time (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)) + ((nationality-2 . englishman) (color-2 . red) (drink-2 . milk) (smoke-2 . oldgold) (pet-2 . snails)) + ((nationality-3 . japanese) (color-3 . green) (drink-3 . coffee) (smoke-3 . parliaments) (pet-3 . zebra)) + ((nationality-4 . spaniard) (color-4 . ivory) (drink-4 . orange-juice) (smoke-4 . luckystrike) (pet-4 . dogs)))) diff --git a/csp/hacs.rkt b/csp/hacs.rkt index 2c809fb9..0eafa96b 100644 --- a/csp/hacs.rkt +++ b/csp/hacs.rkt @@ -1,5 +1,5 @@ #lang debug racket -(require racket/generator) +(require racket/generator graph) (provide (all-defined-out)) (define-syntax-rule (in-cartesian x) @@ -30,7 +30,22 @@ (define (make-constraint [names null] [proc values]) ($constraint names proc)) -(struct $var (name domain) #:transparent) +(define constraint-names $constraint-names) +(define constraint? $constraint?) + +(define (csp->graphviz csp) + (define g (csp->graph csp)) + (graphviz g #:colors (coloring/brelaz g))) + +(define (csp->graph csp) + (for*/fold ([g (unweighted-graph/undirected (map var-name (vars csp)))]) + ([constraint (in-constraints csp)] + [edge (in-combinations (constraint-names constraint) 2)]) + (apply add-edge! g edge) + g)) + +(struct $var (name domain) #:transparent) +(define var? $var?) (define name? symbol?) (define $var-vals $var-domain) (define var-name $var-name) @@ -39,7 +54,8 @@ (struct $avar $var () #:transparent) (define assigned-var? $avar?) -(define (make-csp [vars null] [constraints null]) +(define/contract (make-csp [vars null] [constraints null]) + (() ((listof var?) (listof constraint?)) . ->* . csp?) ($csp vars constraints)) (define/contract (add-vars! csp names-or-procedure [vals-or-procedure empty]) @@ -82,8 +98,6 @@ (any/c any/c . -> . boolean?) (not (= x y))) -(struct inconsistency-signal (csp) #:transparent) - (struct $backtrack (names) #:transparent) (define (backtrack! [names null]) (raise ($backtrack names))) @@ -116,10 +130,10 @@ (define/contract (assigned-name? csp name) (csp? name? . -> . any/c) (for/or ([var (in-vars csp)] - #:when (assigned-var? var)) + #:when (assigned-var? var)) (eq? name (var-name var)))) -(define (reduce-arity proc pattern) +(define (reduce-function-arity proc pattern) (unless (match (procedure-arity proc) [(arity-at-least val) (<= val (length pattern))] [(? number? val) (= val (length pattern))]) @@ -159,7 +173,7 @@ (if (assigned-name? cname) (first ($csp-vals csp cname)) (box cname)))]) - (reduce-arity proc reduce-arity-pattern)))] + (reduce-function-arity proc reduce-arity-pattern)))] [else constraint]))))) (define/contract (assign-val csp name val) @@ -249,7 +263,7 @@ (= 2 (constraint-arity constraint))) (define (constraint-relates? constraint name) - (and (memq name ($constraint-names constraint)) #true)) + (memq name ($constraint-names constraint))) (define/contract (forward-check csp aname) (csp? name? . -> . csp?) @@ -294,16 +308,15 @@ #:unless (and (binary-constraint? constraint) (constraint-relates? constraint aname) - (let ([other-name (first (remq aname ($constraint-names constraint)))]) ; and something else - (= (length ($csp-vals csp other-name)) 1)))) ; that has only one value + (let ([other-name (first (remq aname ($constraint-names constraint)))]) + (singleton-var? (csp-var csp other-name))))) constraint)) (make-csp checked-vars nonsingleton-constraints)) (define/contract (constraint-checkable? c names) - ($constraint? (listof name?) . -> . boolean?) - (and (for/and ([cname (in-list ($constraint-names c))]) - (memq cname names)) - #true)) + ($constraint? (listof name?) . -> . any/c) + (for/and ([cname (in-list ($constraint-names c))]) + (memq cname names))) (define/contract (constraint-arity constraint) ($constraint? . -> . exact-nonnegative-integer?) @@ -325,12 +338,13 @@ (for ([constraint (in-list (sort checkable-constraints < #:key constraint-arity))] #:unless (constraint csp)) (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?) ;; todo: why does this function slow down searches? - ($csp + (make-csp (for/list ([var (in-vars csp)]) (match-define ($var name vals) var) (define procs (for*/list ([constraint (in-constraints csp)]