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.
125 lines
5.2 KiB
Racket
125 lines
5.2 KiB
Racket
#lang racket/base
|
|
(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%
|
|
;; Class used to define a problem and retrieve solutions
|
|
|
|
(class/c [reset (->m void?)]
|
|
[set-solver (solver%? . ->m . void?)]
|
|
[get-solver (->m solver%?)]
|
|
;; todo: tighten `object?` contract
|
|
[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 backtracking-solver%))]
|
|
[_constraints #f]
|
|
[_variables #f])
|
|
|
|
(reset)
|
|
|
|
(define (repr) (format "<problem% ~a>" (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)
|
|
(set! _variables (make-hash)))
|
|
|
|
(define/public (set-solver solver)
|
|
;; Change the problem solver currently in use
|
|
(set! _solver solver))
|
|
|
|
(define/public (get-solver)
|
|
;; Obtain 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)
|
|
(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 (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) (add-variable var domain)) listified-variables))
|
|
|
|
(define/public (add-constraint constraint [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")))
|
|
(py-append! _constraints (list constraint variables)))
|
|
|
|
(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)))
|
|
|
|
(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)))
|
|
|
|
(define/public (get-solution-iter)
|
|
; Return an iterator to the solutions of the problem
|
|
(void))
|
|
|
|
(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))
|
|
(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))
|
|
|
|
|
|
)) |