From dc19ddc1203760a7ba4b09fad9600590194ce516 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 2 Oct 2014 12:59:24 -0700 Subject: [PATCH] reorg --- csp/NOTICES | 33 ++ csp/constraint.rkt | 418 +----------------- csp/domain.rkt | 63 +++ csp/{helpers.rkt => helper.rkt} | 0 csp/main.rkt | 11 + csp/problem.rkt | 117 +++++ csp/solver.rkt | 155 +++++++ csp/test-classes.rkt | 16 + ...constraint-tests.rkt => test-problems.rkt} | 2 +- csp/variable.rkt | 17 + 10 files changed, 416 insertions(+), 416 deletions(-) create mode 100644 csp/NOTICES create mode 100644 csp/domain.rkt rename csp/{helpers.rkt => helper.rkt} (100%) create mode 100644 csp/main.rkt create mode 100644 csp/problem.rkt create mode 100644 csp/solver.rkt create mode 100644 csp/test-classes.rkt rename csp/{constraint-tests.rkt => test-problems.rkt} (98%) create mode 100644 csp/variable.rkt diff --git a/csp/NOTICES b/csp/NOTICES new file mode 100644 index 00000000..8d4bcdd4 --- /dev/null +++ b/csp/NOTICES @@ -0,0 +1,33 @@ +This software includes open-source software components that require the following legal notices. + +=============================================================================== + +python-constraint http://labix.org/python-constraint + +=============================================================================== + +Copyright (c) 2005-2014 - Gustavo Niemeyer + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +=============================================================================== \ No newline at end of file diff --git a/csp/constraint.rkt b/csp/constraint.rkt index d13c06ee..1dfb73c6 100644 --- a/csp/constraint.rkt +++ b/csp/constraint.rkt @@ -1,240 +1,6 @@ #lang racket/base -(require racket/class racket/contract racket/match racket/list racket/generator) -(require sugar/container sugar/debug) -(require "helpers.rkt") -(module+ test (require rackunit)) - -;; Adapted from work by Gustavo Niemeyer -#| -# Copyright (c) 2005-2014 - Gustavo Niemeyer -# -# All rights reserved. -# -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are met: -# -# 1. Redistributions of source code must retain the above copyright notice, this -# list of conditions and the following disclaimer. -# 2. Redistributions in binary form must reproduce the above copyright notice, -# this list of conditions and the following disclaimer in the documentation -# and/or other materials provided with the distribution. -# -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" -# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE -# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, -# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -|# - -(provide (all-defined-out) (all-from-out "helpers.rkt")) -;(provide Problem Variable Domain Unassigned Solver BacktrackingSolver RecursiveBacktrackingSolver MinConflictsSolver Constraint FunctionConstraint AllDifferentConstraint AllEqualConstraint MaxSumConstraint ExactSumConstraint MinSumConstraint InSetConstraint NotInSetConstraint SomeInSetConstraint SomeNotInSetConstraint) - -;(define Problem/c (λ(x) (is-a x Problem))) - -(define/contract Problem - ;; Class used to define a problem and retrieve solutions - - (class/c [reset (->m void?)] - ;; todo: tighten `object?` contracts - [setSolver (object? . ->m . void?)] - [getSolver (->m object?)] - ;; todo: tighten `object?` contract - [addVariable (any/c (or/c list? object?) . ->m . void?)] - [getSolutions (->m list?)]) - (class* object% (printable<%>) - (super-new) - - (init-field [solver #f]) - (field [_solver (or solver (new BacktrackingSolver))] - [_constraints null] - [_variables (make-hash)]) - - - (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)) - - (define/public (reset) - ;; Reset the current problem definition - (set! _constraints null) - (hash-clear! _variables)) - - (define/public (setSolver solver) - ;; Change the problem solver currently in use - (set! _solver solver)) - - (define/public (getSolver) - ;; Obtain the problem solver currently in use - _solver) - - (define/public (addVariable variable domain) - ;; 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]))] - ;; todo: test for `instance-of-Domain?` ; how to copy domain? - [(object? domain) (set! domain '(copy.copy domain))] - [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")) - (hash-set! _variables variable domain)) - - (define/public (addVariables 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)) - - (define/public (addConstraint constraint [variables null]) - ;; Add a constraint to the problem - - (when (not (Constraint? constraint)) - (if (procedure? constraint) - (set! constraint (new FunctionConstraint [func constraint])) - (error 'addConstraint "Constraints must be instances of class Constraint"))) - (py-append! _constraints (list constraint variables))) - - (define/public (getSolution) - ;; Find and return a solution to the problem - (define-values (domains constraints vconstraints) (_getArgs)) - (if (not domains) - null - (send _solver getSolution domains constraints vconstraints))) - - (define/public (getSolutions) - ;; Find and return all solutions to the problem - (define-values (domains constraints vconstraints) (_getArgs)) - (if (not domains) - null - (send _solver getSolutions domains constraints vconstraints))) - - (define/public (_getArgs) - (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)) - (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)) - (define result #f) - (let/ec done - (for ([domain (in-list (hash-values domains))]) - (send domain resetState) - (when (not domain) - (set! result (list null null null)) - (done))) - (set! result (list domains constraints vconstraints))) - (apply values result)) - - - )) - -(module+ test - (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)) - - (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))) - - -;; ---------------------------------------------------------------------- -;; Domains -;; ---------------------------------------------------------------------- - -(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. - - (class* object% (printable<%>) - (super-new) - (init-field set) - (field [_list set][_hidden null][_states null]) - - (define (repr) (format "" _list)) - (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)) - - (define/public (resetState) - ;; Reset to the original domain state, including all possible values - (py-extend! _list _hidden) - (set! _hidden null) - (set! _states null)) - - (define/public (pushState) - ;; Save current domain state - ;; Variables hidden after that call are restored when that state - ;; is popped from the stack. - (py-append! _states (length _list))) - - (define/public (popState) - ;; Restore domain state from the top of the stack - - ;; Variables hidden since the last popped state are then available - ;; again. - (define diff (- (py-pop! _states) (length _list))) - (when (not (= 0 diff)) - (py-extend! _list (take-right _hidden diff)) - (set! _hidden (take _hidden (- (length _hidden) diff))))) - - (define/public (hideValue value) - ;; Hide the given value from the domain - - ;; After that call the given value won't be seen as a possible value - ;; on that domain anymore. The hidden value will be restored when the - ;; previous saved state is popped. - (set! _list (remove value _list)) - (py-append! _hidden value)) - - - (define/public (domain-pop!) - (py-pop! _list)) - - (define/public (copy) - (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)) - - - -;; ---------------------------------------------------------------------- -;; Constraints -;; ---------------------------------------------------------------------- +(require racket/class sugar/container "helper.rkt" "variable.rkt") +(provide (all-defined-out)) (define Constraint (class object% @@ -366,182 +132,4 @@ (return-k)) return-value))) -(define AllDifferentConstraint? (is-a?/c AllDifferentConstraint)) - -;; ---------------------------------------------------------------------- -;; Variables -;; ---------------------------------------------------------------------- - -(define Variable - (class* object% (printable<%>) - (super-new) - (define (repr) (format "" _name)) - (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)) - - (init-field name) - (field [_name name]))) -(define Variable? (is-a?/c Variable)) - -(define Unassigned (new Variable [name "Unassigned"])) - -;; ---------------------------------------------------------------------- -;; Solvers -;; ---------------------------------------------------------------------- - -(define Solver - ;; Abstract base class for solvers - (class object% - (super-new) - (abstract getSolution) - (abstract getSolutions) - (abstract getSolutionIter))) - - -(define BacktrackingSolver - ;; Problem solver with backtracking capabilities - (class Solver - (super-new) - (init-field [forwardcheck #t]) - (field [_forwardcheck forwardcheck]) - - (define/override (getSolutionIter domains constraints vconstraints) - - - - (define forwardcheck _forwardcheck) - (define assignments (make-hash)) - (define queue null) - (define values null) - (define pushdomains null) - (define variable #f) - (define lst null) - (define want-to-return #f) - (define return-k #f) - (let/ec break-loop1 - (set! return-k break-loop1) - (let loop1 () - ;(displayln "starting while loop 1") - - - ;; Mix the Degree and Minimum Remaing Values (MRV) heuristics - (set! lst (sort (for/list ([variable (in-hash-keys domains)]) - (list (* -1 (length (hash-ref vconstraints variable))) - (length (get-field _list (hash-ref domains variable))) - variable)) list-comparator)) - ;(report lst) - (let/ec break-for-loop - (for ([item (in-list lst)]) - (when (not ((last item) . in? . assignments)) - - ; Found unassigned variable - (set! variable (last item)) - ;(report variable unassigned-variable) - (set! values (send (hash-ref domains variable) copy)) - (set! pushdomains - (if forwardcheck - (for/list ([x (in-hash-keys domains)] - #:when (and (not (x . in? . assignments)) - (not (x . equal? . variable)))) - (hash-ref domains x)) - null)) - (break-for-loop))) - - ;; if it makes it through the loop without breaking, then there are - ;; No unassigned variables. We've got a solution. Go back - ;; to last variable, if there's one. - (yield (hash-copy assignments)) - (when (null? queue) (begin - (set! want-to-return #t) - (return-k))) - (define variable-values-pushdomains (py-pop! queue)) - (set! variable (first variable-values-pushdomains)) - (set-field! _list values (second variable-values-pushdomains)) - (set! pushdomains (third variable-values-pushdomains)) - (for ([domain (in-list pushdomains)]) - (send domain popState))) - - ;(report variable variable-preloop-2) - ;(report assignments assignments-preloop-2) - - (let/ec break-loop2 - (let loop2 () - ;(displayln "starting while loop 2") - - ;; We have a variable. Do we have any values left? - ;(report values values-tested) - (when (null? (get-field _list values)) - - ;; No. Go back to last variable, if there's one. - (hash-remove! assignments variable) - (let/ec break-loop3 - (let loop3 () - (if (not (null? queue)) - (let () - (define variable-values-pushdomains (py-pop! queue)) - (set! variable (first variable-values-pushdomains)) - (set-field! _list values (second variable-values-pushdomains)) - (set! pushdomains (third variable-values-pushdomains)) - (when (not (null? pushdomains)) - (for ([domain (in-list pushdomains)]) - (send domain popState))) - (when (not (null? (get-field _list values))) (break-loop3)) - (hash-remove! assignments variable) - (loop3)) - (begin - (set! want-to-return #t) - (return-k)))))) - - ;; Got a value. Check it. - (hash-set! assignments variable (send values domain-pop!)) - - (for ([domain (in-list pushdomains)]) - (send domain pushState)) - ;(report pushdomains pushdomains1) - ;(report domains domains1) - - (let/ec break-for-loop - (for ([cvpair (in-list (hash-ref vconstraints variable))]) - (match-define (list constraint variables) cvpair) - (define the_result (send constraint call variables domains assignments pushdomains)) - ;(report pushdomains pushdomains2) - ;(report domains domains2) - ;(report the_result) - (when (not the_result) - ;; Value is not good. - (break-for-loop))) - (begin ;(displayln "now breaking loop 2") - (break-loop2))) - - (for ([domain (in-list pushdomains)]) - (send domain popState)) - - (loop2))) - - ;; Push state before looking for next variable. - (py-append! queue (list variable (get-field _list (send values copy)) pushdomains)) - ;(report queue new-queue) - (loop1))) - - (if want-to-return - (void) - (error 'getSolutionIter "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) - solution)) - - (define/override (getSolution . args) - (car (apply call-solution-generator #:first-only #t args))) - - (define/override (getSolutions . args) - (apply call-solution-generator args)) - - )) - - - - - +(define AllDifferentConstraint? (is-a?/c AllDifferentConstraint)) \ No newline at end of file diff --git a/csp/domain.rkt b/csp/domain.rkt new file mode 100644 index 00000000..39a66bfa --- /dev/null +++ b/csp/domain.rkt @@ -0,0 +1,63 @@ +#lang racket/base +(require racket/class racket/list "helper.rkt") +(provide (all-defined-out)) + +(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. + + (class* object% (printable<%>) + (super-new) + (init-field set) + (field [_list set][_hidden null][_states null]) + + (define (repr) (format "" _list)) + (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)) + + (define/public (resetState) + ;; Reset to the original domain state, including all possible values + (py-extend! _list _hidden) + (set! _hidden null) + (set! _states null)) + + (define/public (pushState) + ;; Save current domain state + ;; Variables hidden after that call are restored when that state + ;; is popped from the stack. + (py-append! _states (length _list))) + + (define/public (popState) + ;; Restore domain state from the top of the stack + + ;; Variables hidden since the last popped state are then available + ;; again. + (define diff (- (py-pop! _states) (length _list))) + (when (not (= 0 diff)) + (py-extend! _list (take-right _hidden diff)) + (set! _hidden (take _hidden (- (length _hidden) diff))))) + + (define/public (hideValue value) + ;; Hide the given value from the domain + + ;; After that call the given value won't be seen as a possible value + ;; on that domain anymore. The hidden value will be restored when the + ;; previous saved state is popped. + (set! _list (remove value _list)) + (py-append! _hidden value)) + + + (define/public (domain-pop!) + (py-pop! _list)) + + (define/public (copy) + (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)) \ No newline at end of file diff --git a/csp/helpers.rkt b/csp/helper.rkt similarity index 100% rename from csp/helpers.rkt rename to csp/helper.rkt diff --git a/csp/main.rkt b/csp/main.rkt new file mode 100644 index 00000000..0e1f6385 --- /dev/null +++ b/csp/main.rkt @@ -0,0 +1,11 @@ +#lang racket/base +(require + "problem.rkt" + "constraint.rkt" + "helper.rkt") + +(provide (all-from-out + "problem.rkt" + "constraint.rkt" + "helper.rkt")) + diff --git a/csp/problem.rkt b/csp/problem.rkt new file mode 100644 index 00000000..373bf28e --- /dev/null +++ b/csp/problem.rkt @@ -0,0 +1,117 @@ +#lang racket/base +(require racket/class sugar/container racket/contract racket/match "domain.rkt" "helper.rkt" "constraint.rkt" "solver.rkt") +(provide (all-defined-out)) + +(define/contract Problem + ;; Class used to define a problem and retrieve solutions + + (class/c [reset (->m void?)] + ;; todo: tighten `object?` contracts + [setSolver (Solver? . ->m . void?)] + [getSolver (->m Solver?)] + ;; todo: tighten `object?` contract + [addVariable (any/c (or/c list? object?) . ->m . void?)] + [getSolutions (->m list?)]) + (class* object% (printable<%>) + (super-new) + + (init-field [solver #f]) + (field [_solver (or solver (new BacktrackingSolver))] + [_constraints null] + [_variables (make-hash)]) + + + (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)) + + (define/public (reset) + ;; Reset the current problem definition + (set! _constraints null) + (hash-clear! _variables)) + + (define/public (setSolver solver) + ;; Change the problem solver currently in use + (set! _solver solver)) + + (define/public (getSolver) + ;; Obtain the problem solver currently in use + _solver) + + (define/public (addVariable variable domain) + ;; 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]))] + ;; todo: test for `instance-of-Domain?` ; how to copy domain? + [(object? domain) (set! domain '(copy.copy domain))] + [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")) + (hash-set! _variables variable domain)) + + (define/public (addVariables 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)) + + (define/public (addConstraint constraint [variables null]) + ;; Add a constraint to the problem + + (when (not (Constraint? constraint)) + (if (procedure? constraint) + (set! constraint (new FunctionConstraint [func constraint])) + (error 'addConstraint "Constraints must be instances of class Constraint"))) + (py-append! _constraints (list constraint variables))) + + (define/public (getSolution) + ;; Find and return a solution to the problem + (define-values (domains constraints vconstraints) (_getArgs)) + (if (not domains) + null + (send _solver getSolution domains constraints vconstraints))) + + (define/public (getSolutions) + ;; Find and return all solutions to the problem + (define-values (domains constraints vconstraints) (_getArgs)) + (if (not domains) + null + (send _solver getSolutions domains constraints vconstraints))) + + (define/public (_getArgs) + (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)) + (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)) + (define result #f) + (let/ec done + (for ([domain (in-list (hash-values domains))]) + (send domain resetState) + (when (not domain) + (set! result (list null null null)) + (done))) + (set! result (list domains constraints vconstraints))) + (apply values result)) + + + )) \ No newline at end of file diff --git a/csp/solver.rkt b/csp/solver.rkt new file mode 100644 index 00000000..2223859b --- /dev/null +++ b/csp/solver.rkt @@ -0,0 +1,155 @@ +#lang racket/base +(require racket/class sugar/container racket/list racket/generator racket/match "helper.rkt") +(provide (all-defined-out)) + +(define Solver + ;; Abstract base class for solvers + (class object% + (super-new) + (abstract getSolution) + (abstract getSolutions) + (abstract getSolutionIter))) + +(define Solver? (is-a?/c Solver)) + +(define BacktrackingSolver + ;; Problem solver with backtracking capabilities + (class Solver + (super-new) + (init-field [forwardcheck #t]) + (field [_forwardcheck forwardcheck]) + + (define/override (getSolutionIter domains constraints vconstraints) + + + + (define forwardcheck _forwardcheck) + (define assignments (make-hash)) + (define queue null) + (define values null) + (define pushdomains null) + (define variable #f) + (define lst null) + (define want-to-return #f) + (define return-k #f) + (let/ec break-loop1 + (set! return-k break-loop1) + (let loop1 () + ;(displayln "starting while loop 1") + + + ;; Mix the Degree and Minimum Remaing Values (MRV) heuristics + (set! lst (sort (for/list ([variable (in-hash-keys domains)]) + (list (* -1 (length (hash-ref vconstraints variable))) + (length (get-field _list (hash-ref domains variable))) + variable)) list-comparator)) + ;(report lst) + (let/ec break-for-loop + (for ([item (in-list lst)]) + (when (not ((last item) . in? . assignments)) + + ; Found unassigned variable + (set! variable (last item)) + ;(report variable unassigned-variable) + (set! values (send (hash-ref domains variable) copy)) + (set! pushdomains + (if forwardcheck + (for/list ([x (in-hash-keys domains)] + #:when (and (not (x . in? . assignments)) + (not (x . equal? . variable)))) + (hash-ref domains x)) + null)) + (break-for-loop))) + + ;; if it makes it through the loop without breaking, then there are + ;; No unassigned variables. We've got a solution. Go back + ;; to last variable, if there's one. + (yield (hash-copy assignments)) + (when (null? queue) (begin + (set! want-to-return #t) + (return-k))) + (define variable-values-pushdomains (py-pop! queue)) + (set! variable (first variable-values-pushdomains)) + (set-field! _list values (second variable-values-pushdomains)) + (set! pushdomains (third variable-values-pushdomains)) + (for ([domain (in-list pushdomains)]) + (send domain popState))) + + ;(report variable variable-preloop-2) + ;(report assignments assignments-preloop-2) + + (let/ec break-loop2 + (let loop2 () + ;(displayln "starting while loop 2") + + ;; We have a variable. Do we have any values left? + ;(report values values-tested) + (when (null? (get-field _list values)) + + ;; No. Go back to last variable, if there's one. + (hash-remove! assignments variable) + (let/ec break-loop3 + (let loop3 () + (if (not (null? queue)) + (let () + (define variable-values-pushdomains (py-pop! queue)) + (set! variable (first variable-values-pushdomains)) + (set-field! _list values (second variable-values-pushdomains)) + (set! pushdomains (third variable-values-pushdomains)) + (when (not (null? pushdomains)) + (for ([domain (in-list pushdomains)]) + (send domain popState))) + (when (not (null? (get-field _list values))) (break-loop3)) + (hash-remove! assignments variable) + (loop3)) + (begin + (set! want-to-return #t) + (return-k)))))) + + ;; Got a value. Check it. + (hash-set! assignments variable (send values domain-pop!)) + + (for ([domain (in-list pushdomains)]) + (send domain pushState)) + ;(report pushdomains pushdomains1) + ;(report domains domains1) + + (let/ec break-for-loop + (for ([cvpair (in-list (hash-ref vconstraints variable))]) + (match-define (list constraint variables) cvpair) + (define the_result (send constraint call variables domains assignments pushdomains)) + ;(report pushdomains pushdomains2) + ;(report domains domains2) + ;(report the_result) + (when (not the_result) + ;; Value is not good. + (break-for-loop))) + (begin ;(displayln "now breaking loop 2") + (break-loop2))) + + (for ([domain (in-list pushdomains)]) + (send domain popState)) + + (loop2))) + + ;; Push state before looking for next variable. + (py-append! queue (list variable (get-field _list (send values copy)) pushdomains)) + ;(report queue new-queue) + (loop1))) + + (if want-to-return + (void) + (error 'getSolutionIter "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) + solution)) + + (define/override (getSolution . args) + (car (apply call-solution-generator #:first-only #t args))) + + (define/override (getSolutions . args) + (apply call-solution-generator args)) + + )) diff --git a/csp/test-classes.rkt b/csp/test-classes.rkt new file mode 100644 index 00000000..a940df43 --- /dev/null +++ b/csp/test-classes.rkt @@ -0,0 +1,16 @@ +#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)) + +(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)) \ No newline at end of file diff --git a/csp/constraint-tests.rkt b/csp/test-problems.rkt similarity index 98% rename from csp/constraint-tests.rkt rename to csp/test-problems.rkt index 10c415a0..c2b85cf0 100644 --- a/csp/constraint-tests.rkt +++ b/csp/test-problems.rkt @@ -1,5 +1,5 @@ #lang racket -(require "constraint.rkt") +(require "main.rkt") (require rackunit) (define-simple-check (check-hash-items h1 h2) diff --git a/csp/variable.rkt b/csp/variable.rkt new file mode 100644 index 00000000..3c7213f1 --- /dev/null +++ b/csp/variable.rkt @@ -0,0 +1,17 @@ +#lang racket/base +(require racket/class "helper.rkt") +(provide (all-defined-out)) + +(define Variable + (class* object% (printable<%>) + (super-new) + (define (repr) (format "" _name)) + (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)) + + (init-field name) + (field [_name name]))) +(define Variable? (is-a?/c Variable)) + +(define Unassigned (new Variable [name "Unassigned"])) \ No newline at end of file