mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

adjust

Browse Source
main
Matthew Butterick 6 years ago
parent 485c3b3d20
commit b5be07c005
2 changed files with 65 additions and 59 deletions
Show Stats Download Patch File Download Diff File

122
csp/csp.rkt
Unescape Escape View File

@ -7,12 +7,12 @@
(define (make-csp) ($csp null null)) (define (make-csp) ($csp null null))
(define debug (make-parameter #false)) (define debug (make-parameter #false))
(define (in-cartesian xss) (define (in-cartesian argss)
(in-generator (let loop ([xss xss][args empty]) (in-generator (let loop ([argss argss][acc empty])
(if (null? xss) (if (null? argss)
(yield (reverse args)) (yield (reverse acc))
(for ([x (in-list (car xss))]) (for ([arg (in-list (car argss))])
(loop (cdr xss) (cons x args))))))) (loop (cdr argss) (cons arg acc)))))))
(struct $var (name vals) #:transparent) (struct $var (name vals) #:transparent)
(define $var-name? symbol?) (define $var-name? symbol?)
@ -48,12 +48,11 @@
#:result (set-$csp-vars! csp vars)) #:result (set-$csp-vars! csp vars))
([name (in-list names)]) ([name (in-list names)])
(when (memq name (map $var-name vars)) (when (memq name (map $var-name vars))
(raise-argument-error 'add-vars! "var that doesn't exist" name)) (raise-argument-error 'add-vars! "var that doesn't already exist" name))
(append vars (define vals (if (procedure? vals-or-procedure)
(let ([vals (if (procedure? vals-or-procedure) (vals-or-procedure)
(vals-or-procedure) vals-or-procedure))
vals-or-procedure)]) (append vars (list ($var name vals)))))
(list ($var name vals))))))
(define/contract (add-var! csp name [vals-or-procedure empty]) (define/contract (add-var! csp name [vals-or-procedure empty])
(($csp? $var-name?) ((or/c (listof any/c) procedure?)) . ->* . void?) (($csp? $var-name?) ((or/c (listof any/c) procedure?)) . ->* . void?)
@ -64,7 +63,7 @@
(set-$csp-constraints! csp (append ($csp-constraints csp) (set-$csp-constraints! csp (append ($csp-constraints csp)
(for/list ([names (in-list namess)]) (for/list ([names (in-list namess)])
(for ([name (in-list names)]) (for ([name (in-list names)])
(check-name-in-csp! 'add-constraint! csp name)) (check-name-in-csp! 'add-constraints! csp name))
($constraint names (if proc-name ($constraint names (if proc-name
(procedure-rename proc proc-name) (procedure-rename proc proc-name)
proc)))))) proc))))))
@ -88,19 +87,21 @@
(match-define ($constraint (list cname) proc) constraint) (match-define ($constraint (list cname) proc) constraint)
(define new-csp ($csp (for/list ([var (in-list ($csp-vars csp))]) (define new-csp ($csp (for/list ([var (in-list ($csp-vars csp))])
(match-define ($var name vals) var) (match-define ($var name vals) var)
(if (eq? name cname) (cond
;; special rule: use promise for a constant value [(eq? name cname)
;; to skip the filtering ;; special rule: use promise for a constant value
($var name (if (promise? proc) ;; to skip the filtering
(force proc) ($var name (if (promise? proc)
(filter proc vals))) (force proc)
var)) (filter proc vals)))]
[else var]))
;; once the constraint is applied, it can go away ;; once the constraint is applied, it can go away
;; ps this is not the same as an "assigned" constraint ;; ps this is not the same as an "assigned" constraint
;; because the var may still have multiple values ;; because the var may still have multiple values
(remove constraint ($csp-constraints csp)))) (remove constraint ($csp-constraints csp))))
(when (no-solutions? new-csp) (raise (inconsistency-signal))) (if (assigned-name? new-csp cname)
new-csp) (validate-assignments (make-arcs-consistent new-csp #:mac cname))
new-csp))
(define/contract (make-nodes-consistent csp) (define/contract (make-nodes-consistent csp)
($csp? . -> . $csp?) ($csp? . -> . $csp?)
@ -162,13 +163,22 @@
(define (remove-assigned-binary-constraints csp) (define (remove-assigned-binary-constraints csp)
(remove-assigned-constraints csp 2)) (remove-assigned-constraints csp 2))
(define/contract (ac-3 csp) (define/contract (make-arcs-consistent csp #:mac [mac-name #f])
($csp? . -> . $csp?) (($csp?) (#:mac (or/c $var-name? #f)) . ->* . $csp?)
;; as described by AIMA @ 265 ;; csp is arc-consistent if every pair of variables (x y)
(define all-arcs (binary-constraints->arcs (filter binary-constraint? ($csp-constraints csp)))) ;; has values in their domain that satisfy every binary constraint
;; AC-3 as described by AIMA @ 265
(define (mac-condition? arc)
(and
(constraint-contains-name? ($arc-constraint arc) mac-name)
(memq ($arc-name arc) (map $var-name (unassigned-vars csp)))))
(define starting-arcs
(for/list ([arc (in-list (binary-constraints->arcs (filter binary-constraint? ($csp-constraints csp))))]
#:when ((if mac-name mac-condition? values) arc))
arc))
(for/fold ([csp csp] (for/fold ([csp csp]
[arcs all-arcs] [arcs starting-arcs]
#:result (remove-assigned-binary-constraints csp)) #:result csp)
([i (in-naturals)] ([i (in-naturals)]
#:break (empty? arcs)) #:break (empty? arcs))
(match-define (cons arc other-arcs) arcs) (match-define (cons arc other-arcs) arcs)
@ -178,13 +188,7 @@
;; revision did not reduce the domain, so keep going ;; revision did not reduce the domain, so keep going
other-arcs other-arcs
;; revision reduced the domain, so supplement the list of arcs ;; revision reduced the domain, so supplement the list of arcs
(remove-duplicates (append (all-arcs . terminating-at . name) other-arcs)))))) (remove-duplicates (append (starting-arcs . terminating-at . name) other-arcs))))))
(define/contract (make-arcs-consistent csp)
($csp? . -> . $csp?)
;; csp is arc-consistent if every pair of variables (x y)
;; has values in their domain that satisfy every binary constraint
(ac-3 csp))
(define/contract (var-assigned? var) (define/contract (var-assigned? var)
($var? . -> . boolean?) ($var? . -> . boolean?)
@ -232,6 +236,7 @@
(define/contract (order-domain-values vals) (define/contract (order-domain-values vals)
((listof any/c) . -> . (listof any/c)) ((listof any/c) . -> . (listof any/c))
;; todo: least constraining value sort ;; todo: least constraining value sort
vals) vals)
(define/contract (constraint-contains-name? constraint name) (define/contract (constraint-contains-name? constraint name)
@ -249,7 +254,7 @@
(define/contract (assign-val csp name val) (define/contract (assign-val csp name val)
($csp? $var-name? any/c . -> . $csp?) ($csp? $var-name? any/c . -> . $csp?)
(define assignment-constraint ($constraint (list name) (delay (list val)))) (define assignment-constraint ($constraint (list name) (delay (list val))))
(validate-assignments (apply-unary-constraint csp assignment-constraint))) (apply-unary-constraint csp assignment-constraint))
(define (reduce-arity proc pattern) (define (reduce-arity proc pattern)
(unless (match (procedure-arity proc) (unless (match (procedure-arity proc)
@ -282,25 +287,29 @@
(check-equal? 10 ((reduce-arity f '(1 b 3 d)) 2 4)) (check-equal? 10 ((reduce-arity f '(1 b 3 d)) 2 4))
(check-equal? 10 ((reduce-arity f '(a b 3 d)) 1 2 4))) (check-equal? 10 ((reduce-arity f '(a b 3 d)) 1 2 4)))
(define/contract (assigned-name? csp name)
($csp? $var-name? . -> . boolean?)
(and (memq name (map $var-name (assigned-vars csp))) #true))
(define/contract (reduce-constraint-arity csp [minimum-arity 3]) (define/contract (reduce-constraint-arity csp [minimum-arity 3])
(($csp?) (exact-nonnegative-integer?) . ->* . $csp?) (($csp?) (exact-nonnegative-integer?) . ->* . $csp?)
(define (assigned-name? cname) (memq cname (map $var-name (assigned-vars csp)))) (let ([assigned-name? (curry assigned-name? csp)])
(define (partially-assigned? constraint) (define (partially-assigned? constraint)
(ormap assigned-name? ($constraint-names constraint))) (ormap assigned-name? ($constraint-names constraint)))
($csp ($csp-vars csp) ($csp ($csp-vars csp)
(for/list ([constraint (in-list ($csp-constraints csp))]) (for/list ([constraint (in-list ($csp-constraints csp))])
(cond (cond
[(and (<= minimum-arity (constraint-arity constraint)) [(and (<= minimum-arity (constraint-arity constraint))
(partially-assigned? constraint)) (partially-assigned? constraint))
(match-define ($constraint cnames proc) constraint) (match-define ($constraint cnames proc) constraint)
($constraint (filter-not assigned-name? cnames) ($constraint (filter-not assigned-name? cnames)
;; pattern is mix of values and symbols (indicating variables to persist) ;; pattern is mix of values and symbols (indicating variables to persist)
(let ([reduce-arity-pattern (for/list ([cname (in-list cnames)]) (let ([reduce-arity-pattern (for/list ([cname (in-list cnames)])
(if (assigned-name? cname) (if (assigned-name? cname)
($csp-ref csp cname) ($csp-ref csp cname)
cname))]) cname))])
(reduce-arity proc reduce-arity-pattern)))] (reduce-arity proc reduce-arity-pattern)))]
[else constraint])))) [else constraint])))))
(module+ test (module+ test
(define creduce (assign-val ($csp (list ($var 'a '(1 2 3)) ($var 'b '(2 3)) ($var 'c '(1 2 3 4 5))) (list ($constraint '(a b c) (procedure-rename (λ (a b c) (= (+ a b c) 4)) 'summer)))) 'a 1)) (define creduce (assign-val ($csp (list ($var 'a '(1 2 3)) ($var 'b '(2 3)) ($var 'c '(1 2 3 4 5))) (list ($constraint '(a b c) (procedure-rename (λ (a b c) (= (+ a b c) 4)) 'summer)))) 'a 1))
@ -308,13 +317,10 @@
(make-arcs-consistent (reduce-constraint-arity creduce)) (make-arcs-consistent (reduce-constraint-arity creduce))
($csp (list ($var 'a '(1)) ($var 'b '(2)) ($var 'c '(1))) '()))) ($csp (list ($var 'a '(1)) ($var 'b '(2)) ($var 'c '(1))) '())))
;; todo: inferences between assignments
(define/contract (infer csp)
($csp? . -> . $csp?)
(validate-assignments (make-arcs-consistent csp)))
(define/contract (backtracking-solver csp) (define/contract (backtracking-solver csp)
($csp? . -> . generator?) ($csp? . -> . generator?)
;; as described by AIMA @ 271
(generator () (generator ()
(let backtrack ([csp (make-arcs-consistent (make-nodes-consistent csp))]) (let backtrack ([csp (make-arcs-consistent (make-nodes-consistent csp))])
(cond (cond
@ -323,7 +329,7 @@
(match-define ($var name vals) (select-unassigned-var csp)) (match-define ($var name vals) (select-unassigned-var csp))
(for ([val (in-list (order-domain-values vals))]) (for ([val (in-list (order-domain-values vals))])
(with-handlers ([inconsistency-signal? void]) (with-handlers ([inconsistency-signal? void])
(backtrack (infer (assign-val csp name val)))))])))) (backtrack (assign-val csp name val))))]))))
(define/contract (solve* csp [finish-proc values][solution-limit +inf.0]) (define/contract (solve* csp [finish-proc values][solution-limit +inf.0])
(($csp?) (procedure? integer?) . ->* . (listof any/c)) (($csp?) (procedure? integer?) . ->* . (listof any/c))

2
csp/test.rkt
Unescape Escape View File

@ -109,7 +109,7 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu
|# |#
(define xsum (make-csp)) (define xsum (make-csp))
(add-vars! xsum '(l1 l2 l3 l4 r1 r2 r3 r4 x) (λ () (shuffle (range 1 10)))) (add-vars! xsum '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 1 10))
(add-pairwise-constraint! xsum < '(l1 l2 l3 l4)) (add-pairwise-constraint! xsum < '(l1 l2 l3 l4))
(add-pairwise-constraint! xsum < '(r1 r2 r3 r4)) (add-pairwise-constraint! xsum < '(r1 r2 r3 r4))
(add-constraint! xsum (λ (l1 l2 l3 l4 x) (= 27 (+ l1 l2 l3 l4 x))) '(l1 l2 l3 l4 x)) (add-constraint! xsum (λ (l1 l2 l3 l4 x) (= 27 (+ l1 l2 l3 l4 x))) '(l1 l2 l3 l4 x))

Write Preview
Loading…
Cancel
Save