You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/csp/constraint.rkt

347 lines
14 KiB
Racket

#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 <gustavo@niemeyer.net>
#
# 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))
;(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%
(super-new)
(init-field [solver #f])
(field [_solver (or solver (new BacktrackingSolver))]
[_constraints null]
[_variables (make-hash)])
(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
(for-each (λ(var) (addVariable var domain)) 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 (cons constraint variables) constraint-variables-pair)
(when (not variables)
(set! variables allvariables))
(set! constraints (append constraints (list (cons 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 (cons constraint variables) constraint-variables-pair)
(for ([variable (in-list variables)])
(hash-update! vconstraints variable (λ(val) (append val (list (cons constraint variables)))))))
(for ([constraint-variables-pair (in-list constraints)])
(match-define (cons 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))
(displayln (format "The solution to ~a is ~a"
problem
(send problem getSolutions)))
(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 "<Domain ~v>" _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 (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))
;; ----------------------------------------------------------------------
;; 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))
(let ([unassigned-variable variable]) (report 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.
(displayln "solution time")
(report assignments solution-assignments)
(yield (hash-copy assignments))
(report queue)
(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))
(when (not (null? 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?
(displayln (format "values tested ~a" values))
(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.
(report values)
(hash-set! assignments variable (send values domain-pop!))
(when (not (null? pushdomains))
(for ([domain (in-list pushdomains)])
(send domain pushState)))
;; todo: ok replacement for for/else?
(if (not (null? (hash-ref vconstraints variable)))
(let/ec break-for-loop
(for ([cvpair (in-list (hash-ref vconstraints variable))])
(match-define (cons constraint variables) cvpair)
(when (not (constraint variables domains assignments pushdomains))
;; Value is not good.
(break-for-loop))))
(begin (displayln "now breaking loop 2") (break-loop2)))
(when (not (null? pushdomains))
(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/override (getSolution domains constraints vconstraints)
;; todo: fix this
(void))
(define/override (getSolutions domains constraints vconstraints)
(for/list ([solution (in-generator (getSolutionIter domains constraints vconstraints))]) solution))
))
(module+ main
(define p (new Problem))
(define d (new Domain [set '(1 2)]))
)