diff --git a/csp/constraint.rkt b/csp/constraint.rkt index 1f072654..786928eb 100644 --- a/csp/constraint.rkt +++ b/csp/constraint.rkt @@ -3,7 +3,7 @@ (provide (all-defined-out)) -(define Constraint +(define constraint% (class object% (super-new) @@ -67,10 +67,10 @@ return-result) )) -(define Constraint? (is-a?/c Constraint)) +(define constraint%? (is-a?/c constraint%)) -(define FunctionConstraint - (class Constraint +(define function-constraint% + (class constraint% (super-new) (init-field func [assigned #t]) (field [_func func][_assigned assigned]) @@ -96,12 +96,12 @@ (apply _func parms))) )) -(define FunctionConstraint? (is-a?/c FunctionConstraint)) +(define function-constraint%? (is-a?/c function-constraint%)) -(define AllDifferentConstraint +(define all-different-constraint% ;; Constraint enforcing that values of all given variables are different - (class Constraint + (class constraint% (super-new) (define/override (call variables domains assignments [forwardcheck #f] [_unassigned Unassigned]) @@ -133,13 +133,13 @@ (return-k)) return-value))) -(define AllDifferentConstraint? (is-a?/c AllDifferentConstraint)) +(define all-different-constraint%? (is-a?/c all-different-constraint%)) -(define AllEqualConstraint +(define all-equal-constraint% ;; Constraint enforcing that values of all given variables are different - (class Constraint + (class constraint% (super-new) (define/override (call variables domains assignments [forwardcheck #f] [_unassigned Unassigned]) @@ -171,4 +171,4 @@ (return-k)) return-value))) -(define AllEqualConstraint? (is-a?/c AllEqualConstraint)) +(define all-equal-constraint%? (is-a?/c all-equal-constraint%)) diff --git a/csp/domain.rkt b/csp/domain.rkt index 6ba0b1f0..f86b9f7d 100644 --- a/csp/domain.rkt +++ b/csp/domain.rkt @@ -2,7 +2,7 @@ (require racket/class racket/list "helper.rkt") (provide (all-defined-out)) -(define Domain +(define domain% ;; Class used to control possible values for variables ;; When list or tuples are used as domains, they are automatically ;; converted to an instance of that class. @@ -53,12 +53,12 @@ (py-pop! _list)) (define/public (copy) - (define copied-domain (new Domain [set _list])) + (define copied-domain (new domain% [set _list])) (set-field! _hidden copied-domain _hidden) (set-field! _states copied-domain _states) copied-domain) )) -(define Domain? (is-a?/c Domain)) +(define domain%? (is-a?/c domain%)) diff --git a/csp/main.rkt b/csp/main.rkt index 0e1f6385..73d16dac 100644 --- a/csp/main.rkt +++ b/csp/main.rkt @@ -2,10 +2,12 @@ (require "problem.rkt" "constraint.rkt" + "solver.rkt" "helper.rkt") (provide (all-from-out "problem.rkt" "constraint.rkt" + "solver.rkt" "helper.rkt")) diff --git a/csp/problem.rkt b/csp/problem.rkt index 8b8de27a..e6b352a1 100644 --- a/csp/problem.rkt +++ b/csp/problem.rkt @@ -1,26 +1,33 @@ #lang racket/base -(require racket/class sugar/container racket/contract racket/match "domain.rkt" "helper.rkt" "constraint.rkt" "solver.rkt") +(require racket/class sugar/container sugar/debug racket/contract racket/match) +(require "domain.rkt" "helper.rkt" "constraint.rkt" "solver.rkt") (provide (all-defined-out)) -(define/contract Problem +(define/contract problem% ;; Class used to define a problem and retrieve solutions (class/c [reset (->m void?)] - [setSolver (Solver? . ->m . void?)] - [getSolver (->m Solver?)] + [set-solver (solver%? . ->m . void?)] + [get-solver (->m solver%?)] ;; todo: tighten `object?` contract - [addVariable (any/c (or/c list? Domain?) . ->m . void?)] - [getSolutions (->m list?)]) + [add-variable (any/c (or/c list? domain%?) . ->m . void?)] + [add-variables ((listof any/c) (or/c list? domain%?) . ->m . void?)] + [add-constraint (((or/c constraint%? procedure?)) ((listof any/c)) . ->*m . void?)] + [get-solution (->m any/c)] + [get-solutions (->m list?)] + [_get-args (->m (values (listof domain%?) (listof constraint%?) (listof hash?)))]) + (class* object% (printable<%>) (super-new) (init-field [solver #f]) - (field [_solver (or solver (new BacktrackingSolver))] - [_constraints null] - [_variables (make-hash)]) + (field [_solver (or solver (new backtracking-solver%))] + [_constraints #f] + [_variables #f]) + (reset) - (define (repr) (format "" (hash-keys _variables))) + (define (repr) (format "" (hash-keys _variables))) (define/public (custom-print out quoting-depth) (print (repr) out)) (define/public (custom-display out) (displayln (repr) out)) (define/public (custom-write out) (write (repr) out)) @@ -28,61 +35,64 @@ (define/public (reset) ;; Reset the current problem definition (set! _constraints null) - (hash-clear! _variables)) + (set! _variables (make-hash))) - (define/public (setSolver solver) + (define/public (set-solver solver) ;; Change the problem solver currently in use (set! _solver solver)) - (define/public (getSolver) + (define/public (get-solver) ;; Obtain the problem solver currently in use _solver) - (define/public (addVariable variable domain) + (define/public (add-variable variable domain-or-values) ;; Add a variable to the problem - (when (variable . in? . _variables) - (error 'addVariable (format "Tried to insert duplicated variable ~a" variable))) - (cond - [(list? domain) (set! domain (new Domain [set domain]))] - [(Domain? domain) (set! domain (send domain copy))] - [else (error 'addVariable "Domains must be instances of subclasses of Domain")]) - (when (not (object? domain)) (error 'fudge)) - (when (not domain) ; todo: check this test - (error 'addVariable "Domain is empty")) + ;; Contract insures input is Domain object or list of values. + (when (hash-has-key? _variables variable) + (error 'add-variable (format "Tried to insert duplicated variable ~a" variable))) + (define domain (if (domain%? domain-or-values) + (send domain-or-values copy) + (new domain% [set domain-or-values]))) + (when (not (object? domain)) (error 'add-variable "not a Domain object")) + (when (null? (get-field _list domain)) (error 'add-variable "domain value is null")) (hash-set! _variables variable domain)) - (define/public (addVariables variables domain) + (define/public (add-variables variables domain) ;; Add one or more variables to the problem (define listified-variables (cond [(string? variables) (map (λ(c) (format "~a" c)) (string->list variables))] [else variables])) - (for-each (λ(var) (addVariable var domain)) listified-variables)) + (for-each (λ(var) (add-variable var domain)) listified-variables)) - (define/public (addConstraint constraint [variables null]) + (define/public (add-constraint constraint [variables null]) ;; Add a constraint to the problem - (when (not (Constraint? constraint)) + (when (not (constraint%? constraint)) (if (procedure? constraint) - (set! constraint (new FunctionConstraint [func constraint])) - (error 'addConstraint "Constraints must be instances of class Constraint"))) + (set! constraint (new function-constraint% [func constraint])) + (error 'add-constraint "Constraints must be instances of class Constraint"))) (py-append! _constraints (list constraint variables))) - (define/public (getSolution) + (define/public (get-solution) ;; Find and return a solution to the problem - (define-values (domains constraints vconstraints) (_getArgs)) + (define-values (domains constraints vconstraints) (_get-args)) (if (not domains) null - (send _solver getSolution domains constraints vconstraints))) + (send _solver get-solution domains constraints vconstraints))) - (define/public (getSolutions) + (define/public (get-solutions) ;; Find and return all solutions to the problem - (define-values (domains constraints vconstraints) (_getArgs)) + (define-values (domains constraints vconstraints) (_get-args)) (if (not domains) null - (send _solver getSolutions domains constraints vconstraints))) + (send _solver get-solutions domains constraints vconstraints))) + + (define/public (get-solution-iter) + ; Return an iterator to the solutions of the problem + (void)) - (define/public (_getArgs) + (define/public (_get-args) (define domains (hash-copy _variables)) (define allvariables (hash-keys domains)) (define constraints null) diff --git a/csp/solver.rkt b/csp/solver.rkt index 2223859b..357e2fb8 100644 --- a/csp/solver.rkt +++ b/csp/solver.rkt @@ -2,26 +2,24 @@ (require racket/class sugar/container racket/list racket/generator racket/match "helper.rkt") (provide (all-defined-out)) -(define Solver +(define solver% ;; Abstract base class for solvers (class object% (super-new) - (abstract getSolution) - (abstract getSolutions) - (abstract getSolutionIter))) + (abstract get-solution) + (abstract get-solutions) + (abstract get-solution-iter))) -(define Solver? (is-a?/c Solver)) +(define solver%? (is-a?/c solver%)) -(define BacktrackingSolver +(define backtracking-solver% ;; Problem solver with backtracking capabilities - (class Solver + (class solver% (super-new) (init-field [forwardcheck #t]) (field [_forwardcheck forwardcheck]) - (define/override (getSolutionIter domains constraints vconstraints) - - + (define/override (get-solution-iter domains constraints vconstraints) (define forwardcheck _forwardcheck) (define assignments (make-hash)) @@ -139,17 +137,17 @@ (if want-to-return (void) - (error 'getSolutionIter "Whoops, broken solver"))) + (error 'get-solution-iter "Whoops, broken solver"))) (define (call-solution-generator domains constraints vconstraints #:first-only [first-only #f]) - (for/list ([solution (in-generator (getSolutionIter domains constraints vconstraints))] #:final first-only) + (for/list ([solution (in-generator (get-solution-iter domains constraints vconstraints))] #:final first-only) solution)) - (define/override (getSolution . args) + (define/override (get-solution . args) (car (apply call-solution-generator #:first-only #t args))) - (define/override (getSolutions . args) - (apply call-solution-generator args)) - - )) + (define/override (get-solutions . args) + (apply call-solution-generator args)))) + +(define backtracking-solver%? (is-a?/c backtracking-solver%)) diff --git a/csp/test-classes.rkt b/csp/test-classes.rkt index 086f2bdc..427aa61a 100644 --- a/csp/test-classes.rkt +++ b/csp/test-classes.rkt @@ -1,45 +1,71 @@ #lang racket (require rackunit "main.rkt") -(check-equal? (get-field _solver (new Problem [solver 'solver-in])) 'solver-in) -(check-equal? (get-field _constraints (new Problem)) null) -(check-equal? (get-field _variables (new Problem)) (make-hash)) -(define problem (new Problem)) ;; test from line 125 -(send problem addVariable "a" '(1)) -(check-equal? (get-field _list (hash-ref (get-field _variables problem) "a")) '(1)) +;; Problem: fields +(check-equal? (get-field _solver (new problem% [solver 'solver-in])) 'solver-in) +(check-equal? (get-field _constraints (new problem%)) null) +(check-equal? (get-field _variables (new problem%)) (make-hash)) +(define problem null) + +;; Problem: reset +(set! problem (new problem%)) +(define early-solutions (send problem get-solutions)) +(send problem add-variable "a" (range 3)) +(check-not-equal? (send problem get-solutions) early-solutions) (send problem reset) -(check-equal? (get-field _variables problem) (make-hash)) -(send problem addVariables '("a" "b") '(1 2 3)) -(check-equal? (get-field _list (hash-ref (get-field _variables problem) "a")) '(1 2 3)) -(check-equal? (get-field _list (hash-ref (get-field _variables problem) "b")) '(1 2 3)) +(check-equal? (send problem get-solutions) early-solutions) + +;; Problem: setSolver & get-solver +(define solver (new backtracking-solver%)) +(set! problem (new problem% [solver solver])) +(check-true (solver%? (send problem get-solver))) + +;; Problem: add-variable +(set! problem (new problem%)) +(send problem add-variable "a" '(1 2)) +(check-true (or (= (hash-ref (send problem get-solution) "a") 1) + (= (hash-ref (send problem get-solution) "a") 2))) +(check-exn exn:fail? (λ () (send problem add-variable "b" null))) ;; empty domain + + +;; Problem: add-variables +(set! problem (new problem%)) +(send problem add-variables '("a" "b") '(1 2 3)) +(check-equal? (length (send problem get-solutions)) 9) + +;; Problem: add-constraint +(set! problem (new problem%)) +(send problem add-variables '("a" "b") '(1 2 3)) +(send problem add-constraint (λ(a b) (= a (add1 b)))) +(check-equal? (length (send problem get-solutions)) 2) ;; FunctionConstraint, two ways: implicit and explicit (send problem reset) -(send problem addVariables '(a b) '(1 2)) -(send problem addConstraint >) ; implicit -(check-hash-items (send problem getSolution) #hash((a . 1) (b . 2))) +(send problem add-variables '(a b) '(1 2)) +(send problem add-constraint >) ; implicit +(check-hash-items (send problem get-solution) #hash((a . 1) (b . 2))) (send problem reset) -(send problem addVariables '(a b) '(1 2)) -(send problem addConstraint (new FunctionConstraint [func >])) ; explicit -(check-hash-items (send problem getSolution) #hash((a . 1) (b . 2))) +(send problem add-variables '(a b) '(1 2)) +(send problem add-constraint (new function-constraint% [func >])) ; explicit +(check-hash-items (send problem get-solution) #hash((a . 1) (b . 2))) ;; AllDifferentConstraint (send problem reset) -(send problem addVariables '(a b) '(1 2)) -(send problem addConstraint (new AllDifferentConstraint)) -(let ([solutions (send problem getSolutions)]) +(send problem add-variables '(a b) '(1 2)) +(send problem add-constraint (new all-different-constraint%)) +(let ([solutions (send problem get-solutions)]) (check-equal? (hash-ref (first solutions) 'a) (hash-ref (second solutions) 'b)) (check-equal? (hash-ref (second solutions) 'a) (hash-ref (first solutions) 'b))) ;; AllEqualConstraint (send problem reset) -(send problem addVariables '(a b) '(1 2)) -(send problem addConstraint (new AllEqualConstraint)) -(let ([solutions (send problem getSolutions)]) +(send problem add-variables '(a b) '(1 2)) +(send problem add-constraint (new all-equal-constraint%)) +(let ([solutions (send problem get-solutions)]) (check-equal? (hash-ref (first solutions) 'a) (hash-ref (first solutions) 'b)) (check-equal? (hash-ref (second solutions) 'a) (hash-ref (second solutions) 'b))) diff --git a/csp/test-problems.rkt b/csp/test-problems.rkt index 976b9d93..bc901493 100644 --- a/csp/test-problems.rkt +++ b/csp/test-problems.rkt @@ -11,14 +11,14 @@ ;; A+B+C -(define abc-problem (new Problem)) -(send abc-problem addVariables '("a" "b" "c") (range 1 10)) +(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 getSolutions)) +(check-hash-items (argmin test-solution (send abc-problem get-solutions)) #hash(("c" . 9) ("b" . 9) ("a" . 1))) @@ -26,24 +26,24 @@ ;; 26 coins, dollars and quarters ;; that add up to $17. -(define quarter-problem (new Problem)) -(send quarter-problem addVariables '("dollars" "quarters") (range 1 27)) -(send quarter-problem addConstraint (λ(d q) (= 17 (+ d (* 0.25 q)))) '("dollars" "quarters")) -(send quarter-problem addConstraint (λ(d q) (= 26 (+ d q))) '("dollars" "quarters")) -(check-hash-items (send quarter-problem getSolution) '#hash(("dollars" . 14) ("quarters" . 12))) +(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 addVariables '(nickels dimes quarters) (range 1 34)) -(send nickel-problem addConstraint (λ(n d q) (= 33 (+ n d q))) '(nickels dimes quarters)) -(send nickel-problem addConstraint (λ(n d q) (= 3.30 (+ (* 0.05 n) (* 0.1 d) (* 0.25 q)))) '(nickels dimes quarters)) -(send nickel-problem addConstraint (λ(n q) (= n (* 3 q))) '(nickels quarters)) -(send nickel-problem addConstraint (λ(d n) (= n (* 2 d))) '(dimes nickels)) -(check-hash-items (send nickel-problem getSolution) #hash((nickels . 18) (quarters . 6) (dimes . 9))) +(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 #| @@ -57,19 +57,19 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu |# -(define two-four-problem (new Problem)) -(send two-four-problem addVariables '(t w o f u r) (range 10)) -(send two-four-problem addConstraint (new AllDifferentConstraint)) -(send two-four-problem addConstraint (λ(t w o) (> (word-value t w o) 99)) '(t w o)) -(send two-four-problem addConstraint (λ(f o u r) (> (word-value f o u r) 999)) '(f o u r)) -(send two-four-problem addConstraint +(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 getSolutions)) 7) -(send two-four-problem addConstraint (λ(r) (= r 0)) '(r)) -(check-hash-items (send two-four-problem getSolution) #hash((o . 5) (w . 6) (u . 3) (f . 1) (r . 0) (t . 7))) +(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 @@ -85,16 +85,16 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu # |# -(define xsum-problem (new Problem)) -(send xsum-problem addVariables '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 10)) -(send xsum-problem addConstraint (λ (l1 l2 l3 l4 x) +(define xsum-problem (new problem%)) +(send xsum-problem add-variables '(l1 l2 l3 l4 r1 r2 r3 r4 x) (range 10)) +(send xsum-problem 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-problem addConstraint (λ (r1 r2 r3 r4 x) +(send xsum-problem 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-problem addConstraint (new AllDifferentConstraint)) -(check-equal? (length (send xsum-problem getSolutions)) 8) +(send xsum-problem add-constraint (new all-different-constraint%)) +(check-equal? (length (send xsum-problem get-solutions)) 8) @@ -109,37 +109,37 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu # MONEY |# -(define sm-problem (new Problem)) -(send sm-problem addVariables '(s e n d m o r y) (range 10)) -(send sm-problem addConstraint (λ(x) (> x 0)) '(s)) -(send sm-problem addConstraint (λ(x) (> x 0)) '(m)) -(send sm-problem addConstraint (λ(d e y) (= (modulo (+ d e) 10) y)) '(d e y)) -(send sm-problem addConstraint (λ(n d r e y) +(define sm-problem (new problem%)) +(send sm-problem add-variables '(s e n d m o r y) (range 10)) +(send sm-problem add-constraint (λ(x) (> x 0)) '(s)) +(send sm-problem add-constraint (λ(x) (> x 0)) '(m)) +(send sm-problem add-constraint (λ(d e y) (= (modulo (+ d e) 10) y)) '(d e y)) +(send sm-problem add-constraint (λ(n d r e y) (= (modulo (+ (word-value n d) (word-value r e)) 100) (word-value e y))) '(n d r e y)) -(send sm-problem addConstraint (λ(e n d o r y) +(send sm-problem add-constraint (λ(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)) -(send sm-problem addConstraint (λ(s e n d m o r y) (= +(send sm-problem add-constraint (λ(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)) -(send sm-problem addConstraint (new AllDifferentConstraint)) +(send sm-problem add-constraint (new all-different-constraint%)) -(check-hash-items (send sm-problem getSolution) '#hash((m . 1) (e . 5) (r . 8) (n . 6) (y . 2) (o . 0) (d . 7) (s . 9))) +(check-hash-items (send sm-problem get-solution) '#hash((m . 1) (e . 5) (r . 8) (n . 6) (y . 2) (o . 0) (d . 7) (s . 9))) ;; queens problem ;; place queens on chessboard so they do not intersect -(define qp (new Problem)) +(define qp (new problem%)) (define cols (range 8)) (define rows (range 8)) -(send qp addVariables cols rows) +(send qp add-variables cols rows) (for* ([col1 (in-list cols)] [col2 (in-list cols)] #:when (< col1 col2)) - (send qp addConstraint (λ(row1 row2 [col1 col1][col2 col2]) + (send qp 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 qp getSolutions)) 92) \ No newline at end of file +(check-equal? (length (send qp get-solutions)) 92) \ No newline at end of file