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

no exit

Browse Source
main
Matthew Butterick 6 years ago
parent 3214061034
commit a7c79798c4
4 changed files with 121 additions and 43 deletions
Show Stats Download Patch File Download Diff File

110
csp/csp.rkt
Unescape Escape View File

@ -1,6 +1,7 @@
#lang debug racket #lang debug racket
(require racket/generator racket/control sugar/debug) (require racket/generator racket/control sugar/debug)
(provide (all-defined-out)) (provide (all-defined-out))
(struct $csp ([vars #:mutable] (struct $csp ([vars #:mutable]
[constraints #:mutable]) #:transparent) [constraints #:mutable]) #:transparent)
@ -90,7 +91,12 @@
($csp? . -> . boolean?) ($csp? . -> . boolean?)
(zero? (state-count csp))) (zero? (state-count csp)))
(struct inconsistency-signal (names) #:transparent) (struct inconsistency-signal (csp) #:transparent)
(define use-reduce-arity? (make-parameter #t))
(define use-mac? (make-parameter #t))
(define use-remove-constraints? (make-parameter #t))
(define use-validate-assignments? (make-parameter #t))
(define/contract (apply-unary-constraint csp constraint #:culprit [culprit #f]) (define/contract (apply-unary-constraint csp constraint #:culprit [culprit #f])
(($csp? unary-constraint?) (#:culprit (or/c #f $var-name?)) . ->* . $csp?) (($csp? unary-constraint?) (#:culprit (or/c #f $var-name?)) . ->* . $csp?)
@ -106,20 +112,24 @@
(match (if (promise? proc) (match (if (promise? proc)
(force proc) (force proc)
(filter proc ($csp-vals csp name))) (filter proc ($csp-vals csp name)))
[(list) (raise (inconsistency-signal ($varc-culprits ($csp-var csp name))))] [(list) (raise (inconsistency-signal csp))]
[(list assigned-val) (make-nodes-consistent [(list assigned-val) ((if (use-validate-assignments?) make-nodes-consistent values)
(remove-assigned-constraints ((if (use-remove-constraints?) remove-assigned-constraints values)
(reduce-constraint-arity ((if (use-reduce-arity?) reduce-constraint-arity values)
(validate-assignments ((if (use-validate-assignments?) validate-assignments values)
(make-arcs-consistent (let ([csp ($csp
($csp (update-csp-vars name (list assigned-val))
(update-csp-vars name (list assigned-val)) ($csp-constraints csp))])
($csp-constraints csp)) #:mac name)))))] (if (use-mac?)
(make-arcs-consistent csp #:mac name)
csp))))))]
[(list new-vals ...) ($csp (update-csp-vars name new-vals) [(list new-vals ...) ($csp (update-csp-vars name new-vals)
;; 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)))])) (if (use-remove-constraints?)
(remove constraint ($csp-constraints csp))
($csp-constraints csp)))]))
(define/contract (make-nodes-consistent csp) (define/contract (make-nodes-consistent csp)
($csp? . -> . $csp?) ($csp? . -> . $csp?)
@ -215,7 +225,7 @@
(= 1 (remaining-values var))) (= 1 (remaining-values var)))
(define/contract (solution-complete? csp) (define/contract (solution-complete? csp)
($csp? . -> . boolean?) ($csp? . -> . 'lean?)
(and (andmap var-assigned? ($csp-vars csp)) (empty? ($csp-constraints csp)))) (and (andmap var-assigned? ($csp-vars csp)) (empty? ($csp-constraints csp))))
(define (assigned-helper csp) (partition var-assigned? ($csp-vars csp))) (define (assigned-helper csp) (partition var-assigned? ($csp-vars csp)))
@ -240,20 +250,24 @@
#:when (constraint-contains-name? constraint ($var-name var))) #:when (constraint-contains-name? constraint ($var-name var)))
1)) 1))
(define use-mrv? (make-parameter #t))
(define/contract (select-unassigned-var csp) (define/contract (select-unassigned-var csp)
($csp? . -> . (or/c #f $var?)) ($csp? . -> . (or/c #f $var?))
(match (unassigned-vars csp) (match (unassigned-vars csp)
[(list) #f] [(list) #f]
[(list uvars ...) [(list uvars ...)
;; minimum remaining values (MRV) rule (cond
(define mrv-arg (argmin remaining-values uvars)) [(use-mrv?)
(match (filter (λ (var) (= (remaining-values mrv-arg) (remaining-values var))) uvars) ;; minimum remaining values (MRV) rule
[(list winning-uvar) winning-uvar] (define mrv-arg (argmin remaining-values uvars))
[(list mrv-uvars ...) (match (filter (λ (var) (= (remaining-values mrv-arg) (remaining-values var))) uvars)
;; use degree as tiebreaker for mrv [(list winning-uvar) winning-uvar]
(define max-degree-arg (argmax (λ (var) (var-degree csp var)) mrv-uvars)) [(list mrv-uvars ...)
;; use random tiebreaker for degree ;; use degree as tiebreaker for mrv
(first (shuffle (filter (λ (var) (= (var-degree csp max-degree-arg) (var-degree csp var))) mrv-uvars)))])])) (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)))])]
[else (first uvars)])]))
(define/contract (order-domain-values vals) (define/contract (order-domain-values vals)
((listof any/c) . -> . (listof any/c)) ((listof any/c) . -> . (listof any/c))
@ -269,16 +283,22 @@
(define assigned-constraints (filter (λ (c) (constraint-assigned? csp c)) ($csp-constraints csp))) (define assigned-constraints (filter (λ (c) (constraint-assigned? csp c)) ($csp-constraints csp)))
(for ([constraint (in-list (sort assigned-constraints < #:key constraint-arity))] (for ([constraint (in-list (sort assigned-constraints < #:key constraint-arity))]
#:unless (constraint csp)) #:unless (constraint csp))
(raise (inconsistency-signal (for*/list ([name (in-list ($constraint-names constraint))] (raise (inconsistency-signal csp)))
[culprit (in-list ($varc-culprits ($csp-var csp name)))])
culprit))))
csp) csp)
(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?)
(check-name-in-csp! 'assign-val csp name)
(define assignment-constraint ($constraint (list name) (delay (list val)))) (define assignment-constraint ($constraint (list name) (delay (list val))))
(apply-unary-constraint csp assignment-constraint)) (apply-unary-constraint csp assignment-constraint))
(define/contract (assign-val! csp name val)
($csp? $var-name? any/c . -> . void?)
(check-name-in-csp! 'assign-val! csp name)
(define new-csp (assign-val csp name val))
(set-$csp-vars! csp ($csp-vars new-csp))
(set-$csp-constraints! csp ($csp-constraints new-csp)))
(define (reduce-arity proc pattern) (define (reduce-arity proc pattern)
(unless (match (procedure-arity proc) (unless (match (procedure-arity proc)
[(arity-at-least val) (<= val (length pattern))] [(arity-at-least val) (<= val (length pattern))]
@ -325,15 +345,39 @@
(reduce-arity proc reduce-arity-pattern)))] (reduce-arity proc reduce-arity-pattern)))]
[else constraint]))))) [else constraint])))))
(define/contract (select-k names krecs) (define/contract (conflict-set csp name)
((listof $var-name?) (listof (cons/c $var-name? continuation?)) . -> . continuation?) ($csp? $var-name? . -> . (listof $var-name?))
;; earlier assigned variables that participate in constraints with name
(define assigned-names (reverse (map $var-name (assigned-vars csp))))
(define earlier-assigned-names (memq name assigned-names))
(for*/list ([constraint (in-list ($csp-constraints csp))]
[cnames (in-value ($constraint-names constraint))]
#:when (and (andmap (λ (cname) (memq cname earlier-assigned-names)) cnames)
(constraint-contains-name? constraint name))
[cname (in-list cnames)]
#:unless (eq? cname name))
cname))
(define use-cdj? (make-parameter #f))
(define/contract (select-k sig name krecs)
(inconsistency-signal? $var-name? (listof (cons/c $var-name? continuation?)) . -> . continuation?)
;; select the most recent (ie topmost) k that is in the signal ;; select the most recent (ie topmost) k that is in the signal
;; todo: repair backjumping ;; todo: repair backjumping
(cdr (or #;(for/first ([krec (in-list krecs)] (cond
#:when (let ([name (car krec)]) [(use-cdj?)
(memq name names))) (define assigned-names (map car krecs)) ; already in reverse chron order
krec) (define csp (inconsistency-signal-csp sig))
(first krecs)))) (define backjump-dest
(let loop ([name name][cset (conflict-set csp name)])
(define next-name (for/first ([previously-assigned-name (in-list (memq name assigned-names))]
#:when (memq previously-assigned-name cset))
previously-assigned-name))
(define next-cset (conflict-set csp next-name))
(if (empty? next-cset)
next-name
(loop next-name (remq next-name (remove-duplicates (append next-cset cset) eq?))))))
(cdr (assq backjump-dest krecs))]
[else (cdr (first krecs))]))
(define/contract (backtrack-solution-generator csp) (define/contract (backtrack-solution-generator csp)
($csp? . -> . generator?) ($csp? . -> . generator?)
@ -354,7 +398,7 @@
(let ([backjump-krecs (cons (cons name backjump-k) backjump-krecs)]) (let ([backjump-krecs (cons (cons name backjump-k) backjump-krecs)])
(with-handlers ([inconsistency-signal? (with-handlers ([inconsistency-signal?
(λ (sig) (λ (sig)
(define backjump-k (select-k (inconsistency-signal-names sig) backjump-krecs)) (define backjump-k (select-k sig name backjump-krecs))
(backjump-k))]) (backjump-k))])
(backtrack (assign-val csp name val) backjump-krecs)))))))])))) (backtrack (assign-val csp name val) backjump-krecs)))))))]))))
@ -364,7 +408,7 @@
(for/list ([solution (in-producer (backtrack-solution-generator csp) (void))] (for/list ([solution (in-producer (backtrack-solution-generator csp) (void))]
[idx (in-range solution-limit)]) [idx (in-range solution-limit)])
(finish-proc solution))) (finish-proc solution)))
(unless (pair? solutions) (raise (inconsistency-signal null))) (unless (pair? solutions) (raise (inconsistency-signal csp)))
solutions) solutions)
(define/contract (solve csp [finish-proc values]) (define/contract (solve csp [finish-proc values])

24
csp/test-etc.rkt
Unescape Escape View File

@ -0,0 +1,24 @@
#lang at-exp racket
(require "csp.rkt" racket/port rackunit)
(use-mrv? #f)
(use-reduce-arity? #f)
(use-mac? #f)
(use-remove-constraints? #f)
(use-validate-assignments? #t)
(define (neq? x y) (not (eq? x y)))
(define c (make-csp))
(add-vars! c '(wa nsw t q nt v sa) '(red green blue))
(add-constraint! c neq? '(wa nt))
(add-constraint! c neq? '(nt q))
(add-constraint! c neq? '(q nsw))
(add-constraint! c neq? '(nsw v))
(add-constraint! c neq? '(sa wa))
(add-constraint! c neq? '(sa nt))
(add-constraint! c neq? '(sa q))
(add-constraint! c neq? '(sa nsw))
(add-constraint! c neq? '(sa v))
(solve c)

15
csp/test-problems.rkt
Unescape Escape View File

@ -1,6 +1,12 @@
#lang at-exp racket #lang at-exp racket
(require "csp.rkt" rackunit) (require "csp.rkt" rackunit)
(use-mrv? #t)
(use-reduce-arity? #t)
(use-mac? #t)
(use-remove-constraints? #t)
(use-validate-assignments? #t)
(define demo (make-csp)) (define demo (make-csp))
(add-vars! demo '(t w) (range 7)) (add-vars! demo '(t w) (range 7))
(add-var! demo 'o '(2 6 7)) (add-var! demo 'o '(2 6 7))
@ -16,9 +22,8 @@
;; TWO + TWO = FOUR ;; TWO + TWO = FOUR
(define (word-value . xs) (define (word-value . xs)
(let ([xs (reverse xs)]) (for/sum ([(x idx) (in-indexed (reverse xs))])
(for/sum ([i (in-range (length xs))]) (* x (expt 10 idx))))
(* (list-ref xs i) (expt 10 i)))))
(define ttf (make-csp)) (define ttf (make-csp))
(add-vars! ttf '(t w o f u r) (reverse (range 10))) (add-vars! ttf '(t w o f u r) (reverse (range 10)))
@ -131,9 +136,9 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu
|# |#
(define smm (make-csp)) (define smm (make-csp))
(add-vars! smm '(s e n d m o r y) (λ () (reverse (range 10)))) (add-vars! smm '(s e n d m o r y) (λ () (range 10)))
(add-constraint! smm positive? '(s)) (add-constraint! smm positive? '(s))
(add-constraint! smm positive? '(m)) (add-constraint! smm (curry = 1) '(m))
(add-constraint! smm (λ (d e y) (= (modulo (+ d e) 10) y)) '(d e y)) (add-constraint! smm (λ (d e y) (= (modulo (+ d e) 10) y)) '(d e y))
(add-constraint! smm (λ (n d r e y) (add-constraint! smm (λ (n d r e y)
(= (modulo (+ (word-value n d) (word-value r e)) 100) (= (modulo (+ (word-value n d) (word-value r e)) 100)

15
csp/test.rkt
Unescape Escape View File

@ -1,9 +1,14 @@
#lang at-exp racket #lang at-exp racket
(require "csp.rkt" rackunit) (require "csp.rkt" rackunit)
(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))
(check-equal?
(make-arcs-consistent (reduce-constraint-arity creduce))
($csp (list ($var 'a '(1)) ($var 'b '(2)) ($var 'c '(1))) '()))
(define c (make-csp '((a (2 3)) (b (12 14 16)) (c (2 5))) (define f (λ (a b c d) (+ a b c d)))
(list ($constraint '(a c) alldiff=) (check-equal? 10 ((reduce-arity f '(1 b c d)) 2 3 4))
($constraint '(b c) (λ (b c) (zero? (modulo b c))))))) (check-equal? 10 ((reduce-arity f '(1 2 c d)) 3 4))
(check-equal? 10 ((reduce-arity f '(1 2 3 d)) 4))
(solve c) (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))
Write Preview
Loading…
Cancel
Save