changes
parent
b5be07c005
commit
e61783961d
@ -1,13 +1,4 @@
|
||||
#lang racket/base
|
||||
(require
|
||||
"problem.rkt"
|
||||
"constraint.rkt"
|
||||
"solver.rkt"
|
||||
"helper.rkt")
|
||||
|
||||
(provide (all-from-out
|
||||
"problem.rkt"
|
||||
"constraint.rkt"
|
||||
"solver.rkt"
|
||||
"helper.rkt"))
|
||||
(require "port/main.rkt")
|
||||
(provide (all-from-out "port/main.rkt"))
|
||||
|
||||
|
||||
@ -0,0 +1,13 @@
|
||||
#lang racket/base
|
||||
(require
|
||||
"problem.rkt"
|
||||
"constraint.rkt"
|
||||
"solver.rkt"
|
||||
"helper.rkt")
|
||||
|
||||
(provide (all-from-out
|
||||
"problem.rkt"
|
||||
"constraint.rkt"
|
||||
"solver.rkt"
|
||||
"helper.rkt"))
|
||||
|
||||
@ -0,0 +1,130 @@
|
||||
#lang racket
|
||||
(require "main.rkt" "test-classes.rkt")
|
||||
(require rackunit)
|
||||
|
||||
|
||||
;; ABC problem:
|
||||
;; what is the minimum value of
|
||||
|
||||
;; ABC
|
||||
;; -------
|
||||
;; A+B+C
|
||||
|
||||
|
||||
(define abc-problem (new problem%))
|
||||
(send abc-problem add-variables '("a" "b" "c") (range 1 10))
|
||||
(define (test-solution s) (let ([a (hash-ref s "a")]
|
||||
[b (hash-ref s "b")]
|
||||
[c (hash-ref s "c")])
|
||||
(/ (+ (* 100 a) (* 10 b) c) (+ a b c))))
|
||||
|
||||
(check-hash-items (argmin test-solution (send abc-problem get-solutions))
|
||||
#hash(("c" . 9) ("b" . 9) ("a" . 1)))
|
||||
|
||||
|
||||
;; quarter problem:
|
||||
;; 26 coins, dollars and quarters
|
||||
;; that add up to $17.
|
||||
|
||||
(define quarter-problem (new problem%))
|
||||
(send quarter-problem add-variables '("dollars" "quarters") (range 1 27))
|
||||
(send quarter-problem add-constraint (λ(d q) (= 17 (+ d (* 0.25 q)))) '("dollars" "quarters"))
|
||||
(send quarter-problem add-constraint (λ(d q) (= 26 (+ d q))) '("dollars" "quarters"))
|
||||
(check-hash-items (send quarter-problem get-solution) '#hash(("dollars" . 14) ("quarters" . 12)))
|
||||
|
||||
;; coin problem 2
|
||||
#|
|
||||
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 nickel-problem (new problem%))
|
||||
(send nickel-problem add-variables '(nickels dimes quarters) (range 1 34))
|
||||
(send nickel-problem add-constraint (λ(n d q) (= 33 (+ n d q))) '(nickels dimes quarters))
|
||||
(send nickel-problem add-constraint (λ(n d q) (= 3.30 (+ (* 0.05 n) (* 0.1 d) (* 0.25 q)))) '(nickels dimes quarters))
|
||||
(send nickel-problem add-constraint (λ(n q) (= n (* 3 q))) '(nickels quarters))
|
||||
(send nickel-problem add-constraint (λ(d n) (= n (* 2 d))) '(dimes nickels))
|
||||
(check-hash-items (send nickel-problem get-solution) #hash((nickels . 18) (quarters . 6) (dimes . 9)))
|
||||
|
||||
;; word math
|
||||
#|
|
||||
# Assign equal values to equal letters, and different values to
|
||||
# different letters, in a way that satisfies the following sum:
|
||||
#
|
||||
# TWO
|
||||
# + TWO
|
||||
# -----
|
||||
# FOUR
|
||||
|#
|
||||
|
||||
|
||||
(define two-four-problem (new problem%))
|
||||
(send two-four-problem add-variables '(t w o f u r) (range 10))
|
||||
(send two-four-problem add-constraint (new all-different-constraint%))
|
||||
(send two-four-problem add-constraint (λ(t w o) (> (word-value t w o) 99)) '(t w o))
|
||||
(send two-four-problem add-constraint (λ(f o u r) (> (word-value f o u r) 999)) '(f o u r))
|
||||
(send two-four-problem add-constraint
|
||||
(λ (t w o f u r)
|
||||
(let ([two (word-value t w o)]
|
||||
[four (word-value f o u r)])
|
||||
((two . + . two) . = . four))) '(t w o f u r))
|
||||
(check-equal? (length (send two-four-problem get-solutions)) 7)
|
||||
(send two-four-problem add-constraint (λ(r) (= r 0)) '(r))
|
||||
(check-hash-items (send two-four-problem get-solution) #hash((o . 5) (w . 6) (u . 3) (f . 1) (r . 0) (t . 7)))
|
||||
|
||||
|
||||
;; 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 (new problem%))
|
||||
(send xsum add-variables '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 10))
|
||||
(send xsum add-constraint (λ (l1 l2 l3 l4 x)
|
||||
(and (< l1 l2 l3 l4)
|
||||
(= 27 (+ l1 l2 l3 l4 x)))) '(l1 l2 l3 l4 x))
|
||||
(send xsum add-constraint (λ (r1 r2 r3 r4 x)
|
||||
(and (< r1 r2 r3 r4)
|
||||
(= 27 (+ r1 r2 r3 r4 x)))) '(r1 r2 r3 r4 x))
|
||||
(send xsum add-constraint (new all-different-constraint%))
|
||||
(check-equal? (length (send xsum get-solutions)) 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
|
||||
|#
|
||||
|
||||
|
||||
;; queens problem
|
||||
;; place queens on chessboard so they do not intersect
|
||||
|
||||
(define queens-problem (new problem%))
|
||||
(define cols (range 8))
|
||||
(define rows (range 8))
|
||||
(send queens-problem add-variables cols rows)
|
||||
(for* ([col1 (in-list cols)] [col2 (in-list cols)] #:when (< col1 col2))
|
||||
(send queens-problem add-constraint (λ(row1 row2 [col1 col1][col2 col2])
|
||||
(and
|
||||
;; test if two cells are on a diagonal
|
||||
(not (= (abs (- row1 row2)) (abs (- col1 col2))))
|
||||
;; test if two cells are in same row
|
||||
(not (= row1 row2)))) (list col1 col2)))
|
||||
(check-equal? (length (send queens-problem get-solutions)) 92)
|
||||
|
||||
(module+ main
|
||||
(displayln "Tests passed"))
|
||||
@ -1,169 +1,21 @@
|
||||
#lang at-exp racket
|
||||
(require "csp.rkt" rackunit)
|
||||
|
||||
(define demo (make-csp))
|
||||
(add-vars! demo '(t w) (range 7))
|
||||
(add-var! demo 'o '(2 6 7))
|
||||
|
||||
(define (sum-three t w o) (= 3 (+ t w o)))
|
||||
(add-constraint! demo sum-three '(t w o))
|
||||
(add-pairwise-constraint! demo alldiff= '(t w o))
|
||||
(add-pairwise-constraint! demo < '(t w o))
|
||||
|
||||
(check-equal? (time (solve demo)) ($csp (list ($var 't '(0)) ($var 'w '(1)) ($var 'o '(2))) '()))
|
||||
|
||||
|
||||
;; TWO + TWO = FOUR
|
||||
(define ttf (make-csp))
|
||||
(add-vars! ttf '(t w o f u r) (reverse (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-pairwise-constraint! ttf alldiff= '(t w o f u r))
|
||||
(add-constraint! ttf (λ (o r) (= (modulo (+ o o) 10) r)) '(o r))
|
||||
(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 (time (solve ttf)))
|
||||
(check-equal? ttf-solution
|
||||
($csp
|
||||
(list
|
||||
($var 't '(7))
|
||||
($var 'w '(3))
|
||||
($var 'o '(4))
|
||||
($var 'f '(1))
|
||||
($var 'u '(6))
|
||||
($var 'r '(8)))
|
||||
'()))
|
||||
|
||||
(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? (time (solve ttf-solution ttf-print)) "734 + 734 = 1468")
|
||||
|
||||
|
||||
;; ABC problem:
|
||||
;; what is the minimum value of
|
||||
;; ABC
|
||||
;; -------
|
||||
;; A+B+C
|
||||
|
||||
(define abc (make-csp))
|
||||
(add-vars! abc '(a b c) (range 1 10))
|
||||
(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 (time (solve* abc)))
|
||||
(check-equal? (* 9 9 9) (length abc-sols))
|
||||
(check-equal?
|
||||
(argmin solution-score abc-sols)
|
||||
($csp (list ($var 'a '(1)) ($var 'b '(9)) ($var 'c '(9))) '()))
|
||||
|
||||
|
||||
;; quarter problem:
|
||||
;; 26 dollars and quarters
|
||||
;; that add up to $17.
|
||||
|
||||
(define quarters (make-csp))
|
||||
(add-vars! quarters '(dollars quarters) (range 26))
|
||||
(add-constraint! quarters (λ (d q) (= 26 (+ d q))) '(dollars quarters))
|
||||
(add-constraint! quarters (λ (d q) (= 17 (+ d (* 0.25 q)))) '(dollars quarters))
|
||||
(check-equal? (time (solve quarters))
|
||||
($csp (list ($var 'dollars '(14)) ($var 'quarters '(12))) '()))
|
||||
|
||||
|
||||
;; 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 nickels (make-csp))
|
||||
(add-vars! nickels '(n d q) (range 33))
|
||||
(add-constraint! nickels (λ (n d q) (= 33 (+ n d q))) '(n d q) 'count-33)
|
||||
(add-constraint! nickels (λ (n d q) (= 330 (+ (* n 5) (* d 10) (* q 25)))) '(n d q) 'total-3.30)
|
||||
(add-constraint! nickels (λ (n q) (= (* 3 q) n)) '(n q) 'triple-nickel)
|
||||
(add-constraint! nickels (λ (d n) (= (* 2 d) n)) '(d n) 'double-nickel)
|
||||
(check-equal? (time (solve nickels))
|
||||
($csp (list ($var 'n '(18)) ($var 'd '(9)) ($var 'q '(6))) '()))
|
||||
|
||||
|
||||
;; 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 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 f (λ (a b c d) (+ a b c d)))
|
||||
(check-equal? 10 ((reduce-arity f '(1 b c d)) 2 3 4))
|
||||
(check-equal? 10 ((reduce-arity f '(1 2 c d)) 3 4))
|
||||
(check-equal? 10 ((reduce-arity f '(1 2 3 d)) 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))
|
||||
|#
|
||||
|
||||
(define xsum (make-csp))
|
||||
(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 < '(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 (λ (r1 r2 r3 r4 x) (= 27 (+ r1 r2 r3 r4 x))) '(r1 r2 r3 r4 x))
|
||||
(add-pairwise-constraint! xsum alldiff= '(l1 l2 l3 l4 r1 r2 r3 r4 x))
|
||||
|
||||
(check-equal? (length (time (solve* xsum))) 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 (λ (d e y) (= (modulo (+ d e) 10) y)) '(d e y))
|
||||
(add-constraint! smm (λ (n d r e y)
|
||||
(= (modulo (+ (word-value n d) (word-value r e)) 100)
|
||||
(word-value e y))) '(n d r e y))
|
||||
(add-constraint! smm (λ (e n d o r y)
|
||||
(= (modulo (+ (word-value e n d) (word-value o r e)) 1000) (word-value n e y))) '(e n d o r y))
|
||||
(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-pairwise-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 (make-csp))
|
||||
(define qs (for/list ([q 8]) (string->symbol (format "q~a" q))))
|
||||
(define rows (range (length qs)))
|
||||
(add-vars! queens qs rows)
|
||||
(define (q-col q) (string->number (string-trim (symbol->string q) "q")))
|
||||
(for* ([qs (in-combinations qs 2)])
|
||||
(match-define (list qa qb) qs)
|
||||
(match-define (list qa-col qb-col) (map q-col qs))
|
||||
(add-constraint! queens
|
||||
(λ (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)))
|
||||
(make-nodes-consistent ($csp (list ($var 'a '(1)) ($var 'b '(0 1))) (list ($constraint '(b) zero?))))
|
||||
|
||||
(check-equal? 92 (length (time (solve* queens))))
|
||||
(remove-assigned-constraints ($csp (list ($var 'a '(1)) ($var 'b '(0 1))) (list ($constraint '(b) zero?))))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue