do it again

main
Matthew Butterick 6 years ago
parent 5efc1406ff
commit 5b76a51d65

@ -2,118 +2,6 @@
(require sugar "hacs.rkt")
(current-inference forward-check)
(current-select-variable mrv-degree-hybrid)
(current-select-variable mrv)
(current-order-values shuffle)
(current-shuffle #true)
#|
# There are no tricks, just pure logic, so good luck and don't give up.
#
# 1. In a street there are five houses, painted five different colours.
# 2. In each house lives a person of different nationality
# 3. These five homeowners each drink a different kind of beverage, smoke
# different brand of cigar and keep a different pet.
#
# THE QUESTION: WHO OWNS THE zebra?
#
# HINTS
#
# 1. The englishman lives in a red house.
# 2. The spaniard keeps dogs as pets.
# 5. The owner of the Green house drinks coffee.
# 3. The ukrainian drinks tea.
# 4. The Green house is on the left of the ivory house.
# 6. The person who smokes oldgold rears snails.
# 7. The owner of the Yellow house smokes kools.
# 8. The man living in the centre house drinks milk.
# 9. The Norwegian lives in the first house.
# 10. The man who smokes chesterfields lives next to the one who keeps foxes.
# 11. The man who keeps horses lives next to the man who smokes kools.
# 12. The man who smokes luckystrike drinks orangejuice.
# 13. The japanese smokes parliaments.
# 14. The Norwegian lives next to the blue house.
# 15. The man who smokes chesterfields has a neighbour who drinks water.
|#
(define (sym . args) (string->symbol (apply format args)))
(define zebra (make-csp))
(define ns (map (curry sym "nationality-~a") (range 5)))
(define cs (map (curry sym "color-~a") (range 5)))
(define ds (map (curry sym "drink-~a") (range 5)))
(define ss (map (curry sym "smoke-~a") (range 5)))
(define ps (map (curry sym "pet-~a") (range 5)))
(add-vars! zebra ns '(englishman spaniard ukrainian norwegian japanese))
(add-vars! zebra cs '(red ivory green yellow blue))
(add-vars! zebra ds '(tea coffee milk orange-juice water))
(add-vars! zebra ss '(oldgold kools chesterfields luckystrike parliaments))
(add-vars! zebra ps '(dogs snails foxes horses zebra))
(for ([vars (list ns cs ds ss ps)])
(add-pairwise-constraint! zebra neq? vars))
(define (paired-with lval left rval right)
(add-constraint! zebra (λ (left right) (or (not (eq? left lval)) (eq? rval right))) (list left right)))
(define (paired-with* lval lefts rval rights)
(for ([left lefts][right rights])
(paired-with lval left rval right)))
;# 1. The englishman lives in a red house.
('englishman ns . paired-with* . 'red cs)
;# 2. The spaniard keeps dogs as pets.
('spaniard ns . paired-with* . 'dogs ps)
;# 5. The owner of the Green house drinks coffee.
('green cs . paired-with* . 'coffee ds)
;# 3. The ukrainian drinks tea.
('ukrainian ns . paired-with* . 'tea ds)
;# 4. The Green house is on the left of the ivory house.
('green (drop-right cs 1) . paired-with* . 'ivory (drop cs 1))
(add-constraint! zebra (curry neq? 'ivory) (list 'color-0))
(add-constraint! zebra (curry neq? 'green) (list 'color-4))
;# 6. The person who smokes oldgold rears snails.
('oldgold ss . paired-with* . 'snails ps)
;# 7. The owner of the Yellow house smokes kools.
('yellow cs . paired-with* . 'kools ss)
;# 8. The man living in the centre house drinks milk.
(add-constraint! zebra (λ (d) (eq? d 'milk)) (list 'drink-2))
;# 9. The Norwegian lives in the first house.
(add-constraint! zebra (λ (x) (eq? x 'norwegian)) (list 'nationality-0))
(define (next-to lval lefts rval rights)
(lval (drop-right lefts 1) . paired-with* . rval (drop rights 1))
(lval (drop lefts 1) . paired-with* . rval (drop-right rights 1)))
;# 10. The man who smokes chesterfields lives next to the one who keeps foxes.
('chesterfields ss . next-to . 'foxes ps)
;# 11. The man who keeps horses lives next to the man who smokes kools.
;('horses ps . next-to . 'kools ss)
;# 12. The man who smokes luckystrike drinks orangejuice.
('luckystrike ss . paired-with* . 'orange-juice ds)
;# 13. The japanese smokes parliaments.
('japanese ns . paired-with* . 'parliaments ss)
;# 14. The Norwegian lives next to the blue house.
;('norwegian ns . next-to . 'water ds)
;# 15. The man who smokes chesterfields has a neighbour who drinks water.
;('chesterfields ss . next-to . 'water ds)
(define (finish x)
(apply map list (slice-at x 5)))
(map finish (list (time (solve zebra))))
(current-shuffle #true)

@ -1,5 +1,5 @@
#lang debug racket
(require "hacs.rkt" rackunit)
(require "hacs.rkt" rackunit sugar/list)
(current-inference forward-check)
(current-select-variable mrv-degree-hybrid)
@ -155,4 +155,131 @@
(not (= qa-row qb-row)))) ; same row?
(list qa qb)))
(check-equal? 92 (length (time (solve* queens))))
(check-equal? 92 (length (time (solve* queens))))
#|
# There are no tricks, just pure logic, so good luck and don't give up.
#
# 1. In a street there are five houses, painted five different colours.
# 2. In each house lives a person of different nationality
# 3. These five homeowners each drink a different kind of beverage, smoke
# different brand of cigar and keep a different pet.
#
# THE QUESTION: WHO OWNS THE zebra?
#
# HINTS
#
# 1. The englishman lives in a red house.
# 2. The spaniard keeps dogs as pets.
# 5. The owner of the Green house drinks coffee.
# 3. The ukrainian drinks tea.
# 4. The Green house is on the left of the ivory house.
# 6. The person who smokes oldgold rears snails.
# 7. The owner of the Yellow house smokes kools.
# 8. The man living in the centre house drinks milk.
# 9. The Norwegian lives in the first house.
# 10. The man who smokes chesterfields lives next to the one who keeps foxes.
# 11. The man who keeps horses lives next to the man who smokes kools.
# 12. The man who smokes luckystrike drinks orangejuice.
# 13. The japanese smokes parliaments.
# 14. The Norwegian lives next to the blue house.
# 15. The man who smokes chesterfields has a neighbour who drinks water.
|#
(define (sym . args) (string->symbol (apply format args)))
(define zebra (make-csp))
(define ns (map (curry sym "nationality-~a") (range 5)))
(define cs (map (curry sym "color-~a") (range 5)))
(define ds (map (curry sym "drink-~a") (range 5)))
(define ss (map (curry sym "smoke-~a") (range 5)))
(define ps (map (curry sym "pet-~a") (range 5)))
(add-vars! zebra ns '(englishman spaniard ukrainian norwegian japanese))
(add-vars! zebra cs '(red ivory green yellow blue))
(add-vars! zebra ds '(tea coffee milk orange-juice water))
(add-vars! zebra ss '(oldgold kools chesterfields luckystrike parliaments))
(add-vars! zebra ps '(dogs snails foxes horses zebra))
(for ([vars (list ns cs ds ss ps)])
(add-pairwise-constraint! zebra neq? vars))
(define (paired-with lval left rval right)
(add-constraint! zebra (λ (left right) (or (not (eq? left lval)) (eq? rval right))) (list left right)))
(define (paired-with* lval lefts rval rights)
(for ([left lefts][right rights])
(paired-with lval left rval right)))
;# 1. The englishman lives in a red house.
('englishman ns . paired-with* . 'red cs)
;# 2. The spaniard keeps dogs as pets.
('spaniard ns . paired-with* . 'dogs ps)
;# 5. The owner of the Green house drinks coffee.
('green cs . paired-with* . 'coffee ds)
;# 3. The ukrainian drinks tea.
('ukrainian ns . paired-with* . 'tea ds)
;# 4. The Green house is on the left of the ivory house.
('green (drop-right cs 1) . paired-with* . 'ivory (drop cs 1))
(add-constraint! zebra (curry neq? 'ivory) (list 'color-0))
(add-constraint! zebra (curry neq? 'green) (list 'color-4))
;# 6. The person who smokes oldgold rears snails.
('oldgold ss . paired-with* . 'snails ps)
;# 7. The owner of the Yellow house smokes kools.
('yellow cs . paired-with* . 'kools ss)
;# 8. The man living in the centre house drinks milk.
(add-constraint! zebra (λ (d) (eq? d 'milk)) (list 'drink-2))
;# 9. The Norwegian lives in the first house.
(add-constraint! zebra (λ (x) (eq? x 'norwegian)) (list 'nationality-0))
(define (next-to lval lefts rval rights)
(for ([righta (drop-right rights 2)]
[left (cdr lefts)]
[rightb (drop rights 2)])
(add-constraint! zebra (λ (left righta rightb)
(or (not (eq? left lval)) (eq? righta rval) (eq? rval rightb)))
(list left righta rightb)))
(for ([left (list (first lefts) (last lefts))]
[right (list (second rights) (fourth rights))])
(add-constraint! zebra (λ (left right) (or (not (eq? left lval)) (eq? rval right)))
(list left right))))
;# 10. The man who smokes chesterfields lives next to the one who keeps foxes.
('chesterfields ss . next-to . 'foxes ps)
;# 11. The man who keeps horses lives next to the man who smokes kools.
('horses ps . next-to . 'kools ss)
;# 12. The man who smokes luckystrike drinks orangejuice.
('luckystrike ss . paired-with* . 'orange-juice ds)
;# 13. The japanese smokes parliaments.
('japanese ns . paired-with* . 'parliaments ss)
;# 14. The Norwegian lives next to the blue house.
('norwegian ns . next-to . 'blue cs)
;# 15. The man who smokes chesterfields has a neighbour who drinks water.
('chesterfields ss . next-to . 'water ds)
(define (finish x)
(apply map list (slice-at x 5)))
(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))))

@ -111,18 +111,19 @@
[(? number? val) (= val (length pattern))])
(raise-argument-error 'reduce-arity (format "list of length ~a, same as procedure arity" (procedure-arity proc)) pattern))
(define reduced-arity-name (string->symbol (format "reduced-arity-~a" (object-name proc))))
(define-values (id-names vals) (partition symbol? pattern))
(define-values (boxed-id-names vals) (partition box? pattern))
(define id-names (map unbox boxed-id-names))
(define new-arity (length id-names))
(procedure-rename
(λ xs
(unless (= (length xs) new-arity)
(unless (= (length xs) new-arity)
(apply raise-arity-error reduced-arity-name new-arity xs))
(apply proc (for/fold ([acc empty]
[xs xs]
[vals vals]
#:result (reverse acc))
([pat-item (in-list pattern)])
(if (symbol? pat-item)
(if (box? pat-item)
(values (cons (car xs) acc) (cdr xs) vals)
(values (cons (car vals) acc) xs (cdr vals))))))
reduced-arity-name))
@ -139,11 +140,12 @@
(partially-assigned? constraint))
(match-define ($constraint cnames proc) constraint)
($constraint (filter-not assigned-name? cnames)
;; pattern is mix of values and symbols (indicating variables to persist)
;; pattern is mix of values and boxed symbols (indicating variables to persist)
;; use boxes here as cheap way to distinguish id symbols from value symbols
(let ([reduce-arity-pattern (for/list ([cname (in-list cnames)])
(if (assigned-name? cname)
(first ($csp-vals csp cname))
cname))])
(box cname)))])
(reduce-arity proc reduce-arity-pattern)))]
[else constraint])))))
@ -171,9 +173,11 @@
(define/contract (argmin-random-tie proc xs)
(procedure? (non-empty-listof any/c) . -> . any/c)
(define ordered-xs (sort xs < #:key proc))
(first ((if (current-shuffle) shuffle values)
(takef ordered-xs (λ (x) (= (proc (car ordered-xs)) (proc x)))))))
(let* ([xs (sort xs < #:key proc)]
[xs (takef xs (λ (x) (= (proc (car xs)) (proc x))))]
;; don't shuffle short lists, not worth it
[xs ((if (current-shuffle) shuffle values) xs)])
(first xs)))
(define/contract (minimum-remaining-values csp)
($csp? . -> . (or/c #false (and/c $var? (not/c $avar?))))
@ -310,7 +314,7 @@
(define/contract (make-nodes-consistent csp)
($csp? . -> . $csp?)
;; todo: why does this function make searches so much slower?
;; todo: why does this function slow down searches?
($csp
(for/list ([var (in-list ($csp-vars csp))])
(match-define ($var name vals) var)
@ -353,6 +357,8 @@
(loop csp)))
conflicts)]))))
;; todo: min-conflicts solver
(define/contract ($csp-assocs csp)
($csp? . -> . (listof (cons/c $var-name? any/c)))
(for/list ([var (in-list ($csp-vars csp))])

Loading…
Cancel
Save