From 65efb7c595613bf26653d8fcbe057c27269d144d Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 2 Oct 2014 18:26:56 -0700 Subject: [PATCH] refactoring, tests work --- csp/problem.rkt | 85 +++++++++++++++++++++++-------------------- csp/test-classes.rkt | 2 +- csp/test-problems.rkt | 8 ++-- 3 files changed, 50 insertions(+), 45 deletions(-) diff --git a/csp/problem.rkt b/csp/problem.rkt index e6b352a1..3f6ab6d9 100644 --- a/csp/problem.rkt +++ b/csp/problem.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require racket/class sugar/container sugar/debug racket/contract racket/match) +(require racket/class sugar/container sugar/debug racket/contract racket/match racket/generator) (require "domain.rkt" "helper.rkt" "constraint.rkt" "solver.rkt") (provide (all-defined-out)) @@ -23,11 +23,12 @@ (init-field [solver #f]) (field [_solver (or solver (new backtracking-solver%))] [_constraints #f] - [_variables #f]) + [_variable-domains #f]) - (reset) + (reset) ; use method rather than manually set up fields - (define (repr) (format "" (hash-keys _variables))) + ;; implement object printing + (define (repr) (format "" (hash-keys _variable-domains))) (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)) @@ -35,27 +36,27 @@ (define/public (reset) ;; Reset the current problem definition (set! _constraints null) - (set! _variables (make-hash))) + (set! _variable-domains (make-hash))) (define/public (set-solver solver) - ;; Change the problem solver currently in use + ;; Set the problem solver currently in use (set! _solver solver)) (define/public (get-solver) - ;; Obtain the problem solver currently in use + ;; Get the problem solver currently in use _solver) (define/public (add-variable variable domain-or-values) ;; Add a variable to the problem ;; Contract insures input is Domain object or list of values. - (when (hash-has-key? _variables variable) + (when (hash-has-key? _variable-domains 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)) + (when (null? (get-field _list domain)) + (error 'add-variable "domain value is null")) + (hash-set! _variable-domains variable domain)) (define/public (add-variables variables domain) ;; Add one or more variables to the problem @@ -65,60 +66,64 @@ [else variables])) (for-each (λ(var) (add-variable var domain)) listified-variables)) - (define/public (add-constraint constraint [variables null]) + (define/public (add-constraint constraint-or-proc [variables null]) ;; Add a constraint to the problem - - (when (not (constraint%? constraint)) - (if (procedure? constraint) - (set! constraint (new function-constraint% [func constraint])) - (error 'add-constraint "Constraints must be instances of class Constraint"))) + ;; contract guarantees input is procedure or constraint% object + (define constraint (if (procedure? constraint-or-proc) + (new function-constraint% [func constraint-or-proc]) + constraint-or-proc)) (py-append! _constraints (list constraint variables))) + (define-syntax-rule (solution-macro solution-proc null-proc) + (begin + (define-values (domains constraints vconstraints) (_get-args)) + (if (null? domains) + (if null-proc (null-proc null) null) + (send _solver solution-proc domains constraints vconstraints)))) + (define/public (get-solution) ;; Find and return a solution to the problem - (define-values (domains constraints vconstraints) (_get-args)) - (if (not domains) - null - (send _solver get-solution domains constraints vconstraints))) + (solution-macro get-solution #f)) (define/public (get-solutions) ;; Find and return all solutions to the problem - (define-values (domains constraints vconstraints) (_get-args)) - (if (not domains) - null - (send _solver get-solutions domains constraints vconstraints))) + (solution-macro get-solutions #f)) (define/public (get-solution-iter) ; Return an iterator to the solutions of the problem - (void)) + (solution-macro get-solution-iter yield)) (define/public (_get-args) - (define domains (hash-copy _variables)) - (define allvariables (hash-keys domains)) - (define constraints null) - (for ([constraint-variables-pair (in-list _constraints)]) - (match-define (list constraint variables) constraint-variables-pair) - (when (null? variables) - (set! variables allvariables)) - (set! constraints (append constraints (list (list constraint variables))))) - (define vconstraints (make-hash)) - (for ([variable (in-hash-keys domains)]) - (hash-set! vconstraints variable null)) + (define variable-domains (hash-copy _variable-domains)) + (define all-variables (hash-keys variable-domains)) + + ;; set up constraints + (define constraints + (for/list ([constraint-variables-pair (in-list _constraints)]) + (match-define (list constraint variables) constraint-variables-pair) + (list constraint (if (null? variables) all-variables variables)))) + + ;; set up vconstraints + (define vconstraints + (hash-copy ; converts for/hash to mutable hash + (for/hash ([variable (in-hash-keys variable-domains)]) + (values variable null)))) + (for ([constraint-variables-pair (in-list constraints)]) (match-define (list constraint variables) constraint-variables-pair) (for ([variable (in-list variables)]) (hash-update! vconstraints variable (λ(val) (append val (list (list constraint variables))))))) (for ([constraint-variables-pair (in-list constraints)]) (match-define (list constraint variables) constraint-variables-pair) - (send constraint preProcess variables domains constraints vconstraints)) + (send constraint preProcess variables variable-domains constraints vconstraints)) (define result #f) (let/ec done - (for ([domain (in-list (hash-values domains))]) + (for ([domain (in-list (hash-values variable-domains))]) (send domain resetState) (when (not domain) (set! result (list null null null)) (done))) - (set! result (list domains constraints vconstraints))) + (set! result (list variable-domains constraints vconstraints))) (apply values result)) diff --git a/csp/test-classes.rkt b/csp/test-classes.rkt index 427aa61a..39680cc9 100644 --- a/csp/test-classes.rkt +++ b/csp/test-classes.rkt @@ -5,7 +5,7 @@ ;; 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)) +(check-equal? (get-field _variable-domains (new problem%)) (make-hash)) (define problem null) diff --git a/csp/test-problems.rkt b/csp/test-problems.rkt index bc901493..59f99b46 100644 --- a/csp/test-problems.rkt +++ b/csp/test-problems.rkt @@ -131,15 +131,15 @@ A collection of 33 coins, consisting of nickels, dimes, and quarters, has a valu ;; queens problem ;; place queens on chessboard so they do not intersect -(define qp (new problem%)) +(define queens-problem (new problem%)) (define cols (range 8)) (define rows (range 8)) -(send qp add-variables cols rows) +(send queens-problem add-variables cols rows) (for* ([col1 (in-list cols)] [col2 (in-list cols)] #:when (< col1 col2)) - (send qp add-constraint (λ(row1 row2 [col1 col1][col2 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 qp get-solutions)) 92) \ No newline at end of file +(check-equal? (length (send queens-problem get-solutions)) 92) \ No newline at end of file