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

nits

Browse Source
main
Matthew Butterick 6 years ago
parent ffa083c1b5
commit f06623c070
2 changed files with 143 additions and 165 deletions
Show Stats Download Patch File Download Diff File

115
csp/csp/hacs.rkt
Unescape Escape View File

@ -73,19 +73,23 @@
(() ((listof var?) (listof constraint?)) . ->* . csp?) (() ((listof var?) (listof constraint?)) . ->* . csp?)
(csp vars consts)) (csp vars consts))
(define/contract (make-var name [vals null])
((name?) ((listof any/c)) . ->* . var?)
(var name vals))
(define/contract (add-vars! prob names-or-procedure [vals-or-procedure empty]) (define/contract (add-vars! prob names-or-procedure [vals-or-procedure empty])
((csp? (or/c (listof name?) procedure?)) ((or/c (listof any/c) procedure?)) . ->* . void?) ((csp? (or/c (listof name?) procedure?)) ((or/c (listof any/c) procedure?)) . ->* . void?)
(for/fold ([vrs (vars prob)] (for/fold ([vrs (vars prob)]
#:result (set-csp-vars! prob vrs)) #:result (set-csp-vars! prob (reverse vrs)))
([name (in-list (match names-or-procedure ([name (in-list (match names-or-procedure
[(? procedure? proc) (proc)] [(? procedure? proc) (proc)]
[names names]))]) [names names]))])
(when (memq name (map var-name vrs)) (when (memq name (map var-name vrs))
(raise-argument-error 'add-vars! "var that doesn't already exist" name)) (raise-argument-error 'add-vars! "var that doesn't already exist" name))
(append vrs (list (var name (cons (make-var name
(if (procedure? vals-or-procedure) (match vals-or-procedure
(vals-or-procedure) [(? procedure? proc) (proc)]
vals-or-procedure)))))) [vals vals])) vrs)))
(define/contract (add-var! prob name [vals-or-procedure empty]) (define/contract (add-var! prob name [vals-or-procedure empty])
((csp? name?) ((or/c (listof any/c) procedure?)) . ->* . void?) ((csp? name?) ((or/c (listof any/c) procedure?)) . ->* . void?)
@ -206,33 +210,34 @@
(define/contract (assign-val prob name val) (define/contract (assign-val prob name val)
(csp? name? any/c . -> . csp?) (csp? name? any/c . -> . csp?)
(when-debug (set! nassns (add1 nassns))) (begin0
(make-csp (make-csp
(for/list ([vr (in-vars prob)]) (for/list ([vr (in-vars prob)])
(if (eq? name (var-name vr)) (if (eq? name (var-name vr))
(assigned-var name (list val)) (assigned-var name (list val))
vr)) vr))
(constraints prob))) (constraints prob))
(when-debug (set! nassns (add1 nassns)))))
(define/contract (assigned-vars prob)
(csp? . -> . (listof var?)) (define/contract (assigned-vars prob [invert? #f])
(filter assigned-var? (vars prob))) ((csp?) (any/c) . ->* . (listof var?))
((if invert? filter-not filter) assigned-var? (vars prob)))
(define/contract (unassigned-vars prob) (define/contract (unassigned-vars prob)
(csp? . -> . (listof var?)) (csp? . -> . (listof var?))
(filter-not assigned-var? (vars prob))) (assigned-vars prob 'invert))
(define/contract (first-unassigned-variable csp) (define/contract (first-unassigned-variable csp)
(csp? . -> . (or/c #false (and/c var? (not/c assigned-var?)))) (csp? . -> . (or/c #false (and/c var? (not/c assigned-var?))))
(match (unassigned-vars csp) (match (unassigned-vars csp)
[(? empty?) #false] [(== empty) #false]
[xs (first xs)])) [xs (first xs)]))
(define/contract (argmin* proc xs [max-style? #f]) (define/contract (argmin* proc xs [max-style? #f])
((procedure? (listof any/c)) (any/c) . ->* . (listof any/c)) ((procedure? (listof any/c)) (any/c) . ->* . (listof any/c))
;; return all elements that have min value. ;; return all elements that have min value.
(match xs (match xs
[(? empty?) xs] [(== empty) xs]
[(list x) xs] [(list x) xs]
[xs [xs
(define vals (map proc xs)) (define vals (map proc xs))
@ -250,13 +255,13 @@
(define/contract (minimum-remaining-values prob) (define/contract (minimum-remaining-values prob)
(csp? . -> . (or/c #false (and/c var? (not/c assigned-var?)))) (csp? . -> . (or/c #false (and/c var? (not/c assigned-var?))))
(match (unassigned-vars prob) (match (unassigned-vars prob)
[(? empty?) #false] [(== empty) #false]
[uvars (random-pick (argmin* domain-length uvars))])) [uvars (random-pick (argmin* domain-length uvars))]))
(define/contract (max-degree prob) (define/contract (max-degree prob)
(csp? . -> . (or/c #false (and/c var? (not/c assigned-var?)))) (csp? . -> . (or/c #false (and/c var? (not/c assigned-var?))))
(match (unassigned-vars prob) (match (unassigned-vars prob)
[(? empty?) #false] [(== empty) #false]
[uvars (random-pick (argmax* (λ (var) (var-degree prob var)) uvars))])) [uvars (random-pick (argmax* (λ (var) (var-degree prob var)) uvars))]))
(define mrv minimum-remaining-values) (define mrv minimum-remaining-values)
@ -279,7 +284,7 @@
(define/contract (mrv-degree-hybrid prob) (define/contract (mrv-degree-hybrid prob)
(csp? . -> . (or/c #f var?)) (csp? . -> . (or/c #f var?))
(match (unassigned-vars prob) (match (unassigned-vars prob)
[(? empty?) #false] [(== empty) #false]
[uvars [uvars
(max-degree (make-csp (argmin* domain-length uvars) (constraints prob)))])) (max-degree (make-csp (argmin* domain-length uvars) (constraints prob)))]))
@ -326,9 +331,9 @@
(cond (cond
[(assigned-var? vr) vr] [(assigned-var? vr) vr]
[(eq? name (var-name vr)) [(eq? name (var-name vr))
(var name (match (filter satisfies-arc? (domain vr)) (make-var name (match (filter satisfies-arc? (domain vr))
[(? empty?) (backtrack!)] [(? empty?) (backtrack!)]
[vals vals]))] [vals vals]))]
[else vr])) [else vr]))
(constraints prob))) (constraints prob)))
@ -472,10 +477,10 @@
(for/list ([vr (in-vars prob)]) (for/list ([vr (in-vars prob)])
(match-define (var name vals) vr) (match-define (var name vals) vr)
(define name-constraints (filter (λ (const) (constraint-relates? const name)) unary-constraints)) (define name-constraints (filter (λ (const) (constraint-relates? const name)) unary-constraints))
(var name (for/list ([val (in-list vals)] (make-var name (for/list ([val (in-list vals)]
#:when (for/and ([const (in-list name-constraints)]) #:when (for/and ([const (in-list name-constraints)])
((constraint-proc const) val))) ((constraint-proc const) val)))
val))) val)))
other-constraints))) other-constraints)))
(define ((make-hist-proc assocs) . xs) (define ((make-hist-proc assocs) . xs)
@ -494,32 +499,32 @@
(generator () (generator ()
(define reduce-arity-proc (if (current-arity-reduction) reduce-constraint-arity values)) (define reduce-arity-proc (if (current-arity-reduction) reduce-constraint-arity values))
(let loop ([prob ((if (current-node-consistency) make-nodes-consistent values) prob)]) (let loop ([prob ((if (current-node-consistency) make-nodes-consistent values) prob)])
(match (select-unassigned-variable prob) (match (select-unassigned-variable prob)
[#false (yield prob)] [#false (yield prob)]
[(var name domain) [(var name domain)
(define (wants-backtrack? exn) (define (wants-backtrack? exn)
(and (backtrack? exn) (or (let ([bths (backtrack-histories exn)]) (and (backtrack? exn) (or (let ([bths (backtrack-histories exn)])
(or (empty? bths) (for*/or ([bth bths] (or (empty? bths) (for*/or ([bth bths]
[rec bth]) [rec bth])
(eq? name (car rec)))))))) (eq? name (car rec))))))))
(for/fold ([conflicts null] (for/fold ([conflicts null]
#:result (void)) #:result (void))
([val (in-list (order-domain-values domain))]) ([val (in-list (order-domain-values domain))])
(with-handlers ([wants-backtrack? (with-handlers ([wants-backtrack?
(λ (bt) (λ (bt)
(define bths (backtrack-histories bt)) (define bths (backtrack-histories bt))
(append conflicts (remq name (remove-duplicates (append conflicts (remq name (remove-duplicates
(for*/list ([bth bths] (for*/list ([bth bths]
[rec bth]) [rec bth])
(car rec)) eq?))))]) (car rec)) eq?))))])
(let* ([prob (assign-val prob name val)] (let* ([prob (assign-val prob name val)]
;; reduce constraints before inference, ;; reduce constraints before inference,
;; to create more forward-checkable (binary) constraints ;; to create more forward-checkable (binary) constraints
[prob (reduce-arity-proc prob)] [prob (reduce-arity-proc prob)]
[prob (inference prob name)] [prob (inference prob name)]
[prob (check-constraints prob)]) [prob (check-constraints prob)])
(loop prob))) (loop prob)))
conflicts)])))) conflicts)]))))
(define/contract (random-pick xs) (define/contract (random-pick xs)
((non-empty-listof any/c) . -> . any/c) ((non-empty-listof any/c) . -> . any/c)

193
csp/csp/sudoku-jm.rkt
Unescape Escape View File

@ -1,4 +1,4 @@
#lang racket/base #lang debug racket/base
(require racket/match (require racket/match
racket/list racket/list
racket/set) racket/set)
@ -25,43 +25,18 @@
(= (cell-y l) (cell-y r))) (= (cell-y l) (cell-y r)))
;; a grid is a list of cells ;; a grid is a list of cells
(define hrule "-----------")
;; board : string ... -> grid ;; board : string ... -> grid
(define (board . ss) (define (board . ss)
(match-define (for*/fold ([cells null]
(list r1 r2 r3 (== hrule) #:result (reverse cells))
r4 r5 r6 (== hrule) ([str (in-list ss)]
r7 r8 r9) [c (in-port read-char (open-input-string str))]
ss) #:unless (memv c '(#\- #\|)))
(define rs (define-values (row col) (quotient/remainder (length cells) 9))
(list r1 r2 r3 r4 r5 r6 r7 r8 r9)) (cons (cell col row (cond
(flatten [(string->number (string c)) => seteq]
(for/list ([r (in-list rs)] [else anything])) cells)))
[y (in-naturals)])
(parse-row y r))))
(define (parse-row y r)
(for/list ([c (in-string r)]
[i (in-naturals)])
(cond
[(or (= i 3) (= i 7))
(if (char=? c #\|)
empty
(error 'parse-row))]
[else
(define x
(cond [(< i 3) (- i 0)]
[(< i 7) (- i 1)]
[ else (- i 2)]))
(parse-cell y x c)])))
(define (parse-cell y x c)
(cell x y
(if (char=? #\space c)
anything
(seteq (string->number (string c))))))
(define (propagate-one top cs) (define (propagate-one top cs)
(let/ec return (let/ec return
@ -69,7 +44,7 @@
(when (cell-solved? top) (when (cell-solved? top)
(define-values (changed? ncs) (define-values (changed? ncs)
(for/fold ([changed? #f] [ncs empty]) (for/fold ([changed? #f] [ncs empty])
([c (in-list cs)]) ([c (in-list cs)])
(cond (cond
[(neighbor-of? top c) [(neighbor-of? top c)
(define before (define before
@ -78,12 +53,12 @@
(set-subtract before (cell-can-be top))) (set-subtract before (cell-can-be top)))
(if (= (set-count before) (if (= (set-count before)
(set-count after)) (set-count after))
(values changed? (values changed?
(cons c ncs)) (cons c ncs))
(values #t (values #t
(cons (struct-copy cell c (cons (struct-copy cell c
[can-be after]) [can-be after])
ncs)))] ncs)))]
[else [else
(values changed? (cons c ncs))]))) (values changed? (cons c ncs))])))
(return changed? top ncs)) (return changed? top ncs))
@ -94,10 +69,10 @@
(define before (cell-can-be top)) (define before (cell-can-be top))
(define after (define after
(for/fold ([before before]) (for/fold ([before before])
([c (in-list cs)]) ([c (in-list cs)])
(if (same-x? top c) (if (same-x? top c)
(set-subtract before (cell-can-be c)) (set-subtract before (cell-can-be c))
before))) before)))
(when (= (set-count after) 1) (when (= (set-count after) 1)
(return #t (return #t
(struct-copy cell top (struct-copy cell top
@ -153,8 +128,8 @@
(define-values (changed? ntop nmore) (define-values (changed? ntop nmore)
(f top (append tried more))) (f top (append tried more)))
(if changed? (if changed?
(values #t (cons ntop nmore)) (values #t (cons ntop nmore))
(loop (cons top tried) more))]))) (loop (cons top tried) more))])))
(define (propagate g) (define (propagate g)
(find-pivot propagate-one g)) (find-pivot propagate-one g))
@ -162,12 +137,12 @@
(define (until-fixed-point f o bad? end-f) (define (until-fixed-point f o bad? end-f)
(define-values (changed? no) (f o)) (define-values (changed? no) (f o))
(if changed? (if changed?
(cons (cons
no no
(if (bad? no) (if (bad? no)
(end-f no) (end-f no)
(until-fixed-point f no bad? end-f))) (until-fixed-point f no bad? end-f)))
(end-f o))) (end-f o)))
(define (solved? g) (define (solved? g)
(andmap (λ (c) (= (set-count (cell-can-be c)) 1)) g)) (andmap (λ (c) (= (set-count (cell-can-be c)) 1)) g))
@ -178,10 +153,10 @@
;; solve-it : grid -> (listof grid) ;; solve-it : grid -> (listof grid)
(define (solve-it g) (define (solve-it g)
(let solve-loop (let solve-loop
([g g] ([g g]
[backtrack! [backtrack!
(λ (i) (λ (i)
(error 'solve-it "Failed!"))]) (error 'solve-it "Failed!"))])
(define (done? g) (define (done? g)
(cond (cond
[(solved? g) [(solved? g)
@ -236,14 +211,14 @@
(define (draw-can-be can-be) (define (draw-can-be can-be)
(define (figi i) (define (figi i)
(if (set-member? can-be i) (if (set-member? can-be i)
(fig (number->string i)) (fig (number->string i))
(fig " "))) (fig " ")))
(place-image/align (place-image/align
(if (= 1 (set-count can-be)) (if (= 1 (set-count can-be))
(scale 3 (fig (number->string (set-first can-be)))) (scale 3 (fig (number->string (set-first can-be))))
(above (beside (figi 1) (figi 2) (figi 3)) (above (beside (figi 1) (figi 2) (figi 3))
(beside (figi 4) (figi 5) (figi 6)) (beside (figi 4) (figi 5) (figi 6))
(beside (figi 7) (figi 8) (figi 9)))) (beside (figi 7) (figi 8) (figi 9))))
0 0 0 0
"left" "top" "left" "top"
(rectangle CELL-W CELL-H (rectangle CELL-W CELL-H
@ -254,7 +229,7 @@
(for/fold ([i (for/fold ([i
(empty-scene (* CELL-W 11) (empty-scene (* CELL-W 11)
(* CELL-H 11))]) (* CELL-H 11))])
([c (in-list g)]) ([c (in-list g)])
(match-define (cell x y can-be) c) (match-define (cell x y can-be) c)
(place-image/align (place-image/align
(draw-can-be can-be) (draw-can-be can-be)
@ -269,60 +244,58 @@
"left" "top" "left" "top"
i))) i)))
(big-bang (draw-state 0 empty gs) (big-bang (draw-state 0 empty gs)
(on-tick move-right 1/8) (on-tick move-right 1/8)
(on-draw draw-draw-state))) (on-draw draw-draw-state)))
;; Wikipedia Example ;; Wikipedia Example
(define b1 (define b1
(board (board
"53 | 7 | " "53 | 7 | "
"6 |195| " "6 |195| "
" 98| | 6 " " 98| | 6 "
"-----------" "-----------"
"8 | 6 | 3" "8 | 6 | 3"
"4 |8 3| 1" "4 |8 3| 1"
"7 | 2 | 6" "7 | 2 | 6"
"-----------" "-----------"
" 6 | |28 " " 6 | |28 "
" |419| 5" " |419| 5"
" | 8 | 79")) " | 8 | 79"))
;; "Hard" example ;; "Hard" example
(define b2 (define b2
(board (board
" 7 | 2 | 5" " 7 | 2 | 5"
" 9| 87| 3" " 9| 87| 3"
" 6 | | 4 " " 6 | | 4 "
"-----------" "-----------"
" | 6 | 17" " | 6 | 17"
"9 4| |8 6" "9 4| |8 6"
"71 | 5 | " "71 | 5 | "
"-----------" "-----------"
" 9 | | 8 " " 9 | | 8 "
"5 |21 |4 " "5 |21 |4 "
"4 | 9 | 6 ")) "4 | 9 | 6 "))
;; "Evil" example ;; "Evil" example
(define b3 (define b3
(board (board
" 8| | 45" " 8| | 45"
" | 8 |9 " " | 8 |9 "
" 2|4 | " " 2|4 | "
"-----------" "-----------"
"5 | 1|76 " "5 | 1|76 "
" 1 | 7 | 8 " " 1 | 7 | 8 "
" 79|5 | 1" " 79|5 | 1"
"-----------" "-----------"
" | 7|4 " " | 7|4 "
" 7| 6 | " " 7| 6 | "
"65 | |3 ")) "65 | |3 "))
#;(draw-state-i #;(draw-state-i
(draw-it! (draw-it!
(solve-it (solve-it
b2))) b2)))
(require sugar/debug) (require sugar/debug)
(time-avg 10 (void (solve-it b1))) (time-avg 10 (void (solve-it b1)))
(time-avg 10 (void (solve-it b2))) (time-avg 10 (void (solve-it b2)))

Write Preview
Loading…
Cancel
Save