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

more probs

Browse Source
main
Matthew Butterick 6 years ago
parent 8af1407e12
commit 78dfe65b98
2 changed files with 162 additions and 40 deletions
Show Stats Download Patch File Download Diff File

64
csp/csp.rkt
Unescape Escape View File

@ -126,13 +126,30 @@
#:when (eq? name (second ($constraint-names ($arc-constraint arc)))))
arc))
(define/contract (constraint-names-assigned? csp constraint)
($csp? $constraint? . -> . boolean?)
(define assigned-var-names
(for/list ([var (in-list (assigned-vars csp))])
($var-name var)))
(match-define ($constraint names _) constraint)
(for/and ([name (in-list names)])
(memq name assigned-var-names)))
(define/contract (remove-obsolete-constraints csp)
($csp? . -> . $csp?)
($csp
($csp-vars csp)
(for/list ([constraint (in-list ($csp-constraints csp))]
#:unless (constraint-names-assigned? csp constraint))
constraint)))
(define/contract (ac-3 csp)
($csp? . -> . $csp?)
;; as described by AIMA @ 265
(define all-arcs (binary-constraints->arcs (filter binary-constraint? ($csp-constraints csp))))
(for/fold ([csp csp]
[arcs all-arcs]
#:result csp)
#:result (remove-obsolete-constraints csp))
([i (in-naturals)]
#:break (empty? arcs))
(match-define (cons arc other-arcs) arcs)
@ -173,7 +190,10 @@
(define/contract (select-unassigned-var csp)
($csp? . -> . $var?)
;; minimum remaining values (MRV) rule
(argmin (λ (var) (length ($var-vals var))) (unassigned-vars csp)))
(define uvars (unassigned-vars csp))
(when (empty? uvars)
(raise-argument-error 'select-unassigned-var "nonempty list of vars" uvars))
(argmin (λ (var) (length ($var-vals var))) uvars))
(define/contract (order-domain-values vals)
((listof any/c) . -> . (listof any/c))
@ -197,43 +217,45 @@
(for/and ([cname (in-list cnames)])
(memq cname assigned-names)))))
(unless (constraint csp) (raise ($csp-inconsistent)))
($csp ($csp-vars csp) (remove constraint ($csp-constraints csp)))))
(remove-obsolete-constraints csp)))
(define gen-stop-val (gensym))
(define/contract (backtrack-solver csp)
(define solver-stop-val (gensym 'solver-stop))
(define/contract (backtracking-solution-generator csp)
($csp? . -> . generator?)
(generator ()
(let backtrack ([csp csp])
(cond
[(assignment-complete? csp) (yield csp)]
[else
(match-define ($var name vals) (select-unassigned-var csp))
(for ([val (in-list (order-domain-values vals))])
(with-handlers ([$csp-inconsistent? (λ (exn) #f)])
(backtrack (infer (assign-val csp name val)))))
gen-stop-val]))))
(define (make-backtrack-iterator csp)
(backtrack-solver (make-arcs-consistent (make-nodes-consistent csp))))
(begin0
solver-stop-val
(let backtrack ([csp csp])
(cond
[(assignment-complete? csp) (yield csp)]
[else ;; we have at least 1 unassigned var
(match-define ($var name vals) (select-unassigned-var csp))
(for ([val (in-list (order-domain-values vals))])
(with-handlers ([$csp-inconsistent? (const #f)])
(backtrack (infer (assign-val csp name val)))))])))))
(define (backtracking-solver csp)
(backtracking-solution-generator (make-arcs-consistent (make-nodes-consistent csp))))
(define/contract (solve csp [finish-proc values])
(($csp?) (procedure?) . ->* . any/c)
(or
(for/first ([solution (in-producer (make-backtrack-iterator csp) gen-stop-val)])
(for/first ([solution (in-producer (backtracking-solver csp) solver-stop-val)])
(finish-proc solution))
(raise ($csp-inconsistent))))
(define/contract (solve* csp [finish-proc values])
(($csp?) (procedure?) . ->* . (listof any/c))
(define solutions (for/list ([solution (in-producer (make-backtrack-iterator csp) gen-stop-val)])
(define solutions (for/list ([solution (in-producer (backtracking-solver csp) solver-stop-val)])
(finish-proc solution)))
(when (empty? solutions) (raise ($csp-inconsistent)))
solutions)
(define ($csp-ref csp name)
(car ($csp-vals csp name)))
(define/contract (alldiff . xs)
(() #:rest (listof any/c) . ->* . boolean?)
(for/and ([comb (in-combinations xs 2)])
(not (apply equal? comb))))
(= (length (remove-duplicates xs)) (length xs)))

138
csp/test.rkt
Unescape Escape View File

@ -15,34 +15,35 @@
;; TWO + TWO = FOUR
(define ttf (make-csp))
(add-vars! ttf '(t w o f u r c10 c100) (range 10))
(add-vars! ttf '(t w o f u r) (range 10))
(define (word-value . xs)
(let ([xs (reverse xs)])
(for/sum ([i (in-range (length xs))])
(* (list-ref xs i) (expt 10 i)))))
(add-constraint! ttf alldiff '(t w o f u r))
(define (adder arg1 arg2 ones-digit tens-digit)
(= (+ arg1 arg2) (+ (* 10 tens-digit) ones-digit)))
(add-constraint! ttf adder '(o o r c10))
(add-constraint! ttf adder '(w w u c100))
(add-constraint! ttf adder '(t t o f))
(add-constraint! ttf (λ (t w o f u r) (= (+ (word-value t w o) (word-value t w o))
(word-value f o u r))) '(t w o f u r))
(add-constraint! ttf positive? '(t))
(add-constraint! ttf positive? '(f))
(define ttf-solution (solve ttf))
(check-equal? ttf-solution
($csp
(list
($var 'c100 '(0))
($var 'c10 '(0))
($var 'r '(8))
($var 'u '(6))
($var 'r '(0))
($var 'u '(3))
($var 'f '(1))
($var 'o '(4))
($var 'w '(3))
($var 'o '(5))
($var 'w '(6))
($var 't '(7)))
'()))
(define (ttf-print csp)
(format "~a~a~a + ~a~a~a = ~a~a~a~a" ($csp-ref csp 't) ($csp-ref csp 'w) ($csp-ref csp 'o) ($csp-ref csp 't) ($csp-ref csp 'w) ($csp-ref csp 'o) ($csp-ref csp 'f) ($csp-ref csp 'o) ($csp-ref csp 'u) ($csp-ref csp 'r)))
(check-equal? (solve ttf-solution ttf-print) "734 + 734 = 1468")
(check-equal? (solve ttf-solution ttf-print) "765 + 765 = 1530")
;; ABC problem:
@ -53,12 +54,111 @@
(define abc (make-csp))
(add-vars! abc '(a b c) (range 1 10))
(define (solution-score abc)
(let ([a ($csp-ref abc 'a)]
[b ($csp-ref abc 'b)]
[c ($csp-ref abc 'c)])
(define (solution-score sol)
(let ([a ($csp-ref sol 'a)]
[b ($csp-ref sol 'b)]
[c ($csp-ref sol 'c)])
(/ (+ (* 100 a) (* 10 b) c) (+ a b c))))
(define abc-sols (solve* abc))
(check-equal? (* 9 9 9) (length abc-sols))
(check-equal?
(argmin solution-score (solve* abc))
($csp (list ($var 'c '(9)) ($var 'b '(9)) ($var 'a '(1))) '()))
(argmin solution-score abc-sols)
($csp (list ($var 'c '(9)) ($var 'b '(9)) ($var 'a '(1))) '()))
;; quarter problem:
;; 26 dollars and quarters
;; that add up to $17.
(define quarter-problem (make-csp))
(add-vars! quarter-problem '(dollars quarters) (range 26))
(add-constraint! quarter-problem (λ (d q) (= 26 (+ d q))) '(dollars quarters))
(add-constraint! quarter-problem (λ (d q) (= 17 (+ d (* 0.25 q)))) '(dollars quarters))
(check-equal? (solve quarter-problem)
($csp (list ($var 'quarters '(12)) ($var 'dollars '(14))) '()))
;; nickel problem
#|
A collection of 33 coins, consisting of nickels, dimes, and quarters, has a value of $3.30. If there are three times as many nickels as quarters, and one-half as many dimes as nickels, how many coins of each kind are there?
|#
(define ndq-problem (make-csp))
(add-vars! ndq-problem '(n d q) (range 33))
(add-constraint! ndq-problem (λ (n d q) (= 33 (+ n d q))) '(n d q))
(add-constraint! ndq-problem (λ (n d q) (= 330 (+ (* n 5) (* d 10) (* q 25)))) '(n d q))
(add-constraint! ndq-problem (λ (n q) (= (* 3 q) n)) '(n q))
(add-constraint! ndq-problem (λ (d n) (= (* 2 d) n)) '(d n))
(check-equal? (solve ndq-problem)
($csp (list ($var 'q '(6)) ($var 'd '(9)) ($var 'n '(18))) '()))
;; xsum
#|
# Reorganize the following numbers in a way that each line of
# 5 numbers sum to 27.
#
# 1 6
# 2 7
# 3
# 8 4
# 9 5
#
|#
(define xsum-problem (make-csp))
(add-vars! xsum-problem '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 1 10))
(add-constraint! xsum-problem (λ (l1 l2 l3 l4 x)
(and (< l1 l2 l3 l4)
(= 27 (+ l1 l2 l3 l4 x)))) '(l1 l2 l3 l4 x))
(add-constraint! xsum-problem (λ (r1 r2 r3 r4 x)
(and (< r1 r2 r3 r4)
(= 27 (+ r1 r2 r3 r4 x)))) '(r1 r2 r3 r4 x))
(add-constraint! xsum-problem alldiff '(l1 l2 l3 l4 r1 r2 r3 r4 x))
;; todo: too slow
#;(check-equal? (length (solve* xsum-problem)) 8)
;; send more money problem
#|
# Assign equal values to equal letters, and different values to
# different letters, in a way that satisfies the following sum:
#
# SEND
# + MORE
# ------
# MONEY
|#
(define smm (make-csp))
(add-vars! smm '(s e n d m o r y) (range 10))
(add-constraint! smm positive? '(s))
(add-constraint! smm positive? '(m))
(add-constraint! smm (λ (s e n d m o r y)
(= (+ (word-value s e n d) (word-value m o r e))
(word-value m o n e y))) '(s e n d m o r y))
(add-constraint! smm alldiff '(s e n d m o r y))
;; todo: too slow
;(solve smm)
;; queens problem
;; place queens on chessboard so they do not intersect
(define queens-problem (make-csp))
(define queens '(q0 q1 q2 q3 q4 q5 q6 q7))
(define rows (range 8))
(add-vars! queens-problem queens rows)
(for* ([(qa qa-col) (in-indexed queens)]
[(qb qb-col) (in-indexed queens)]
#:when (< qa-col qb-col))
(add-constraint! queens-problem
(λ (qa-row qb-row)
(and
(not (= (abs (- qa-row qb-row)) (abs (- qa-col qb-col)))) ; same diagonal?
(not (= qa-row qb-row)))) ; same row?
(list qa qb)))
(check-equal? 92 (length (solve* queens-problem)))

Write Preview
Loading…
Cancel
Save