|
|
|
@ -6,7 +6,7 @@
|
|
|
|
(class object%
|
|
|
|
(class object%
|
|
|
|
(super-new)
|
|
|
|
(super-new)
|
|
|
|
|
|
|
|
|
|
|
|
(define/public (is-true? variables domains assignments [forward-check? #f])
|
|
|
|
(define/public (broken? variables domains assignments [forward-check? #f])
|
|
|
|
;; Perform the constraint checking
|
|
|
|
;; Perform the constraint checking
|
|
|
|
|
|
|
|
|
|
|
|
;; If the forwardcheck parameter is not false, besides telling if
|
|
|
|
;; If the forwardcheck parameter is not false, besides telling if
|
|
|
|
@ -31,7 +31,7 @@
|
|
|
|
(set-field! _list domain
|
|
|
|
(set-field! _list domain
|
|
|
|
(for/fold ([domain-values (domain)])
|
|
|
|
(for/fold ([domain-values (domain)])
|
|
|
|
([value (in-list (domain))]
|
|
|
|
([value (in-list (domain))]
|
|
|
|
#:when (not (is-true? variables domains (make-hash (list (cons variable value))))))
|
|
|
|
#:when (not (broken? variables domains (make-hash (list (cons variable value))))))
|
|
|
|
(remove value domain-values)))
|
|
|
|
(remove value domain-values)))
|
|
|
|
(set! constraints (remove (list this variables) constraints))
|
|
|
|
(set! constraints (remove (list this variables) constraints))
|
|
|
|
(hash-update! vconstraints variable (λ(val) (remove (list this variables) val)))))
|
|
|
|
(hash-update! vconstraints variable (λ(val) (remove (list this variables) val)))))
|
|
|
|
@ -50,7 +50,7 @@
|
|
|
|
(define unassigned-variable-domain (hash-ref domains unassigned-variable))
|
|
|
|
(define unassigned-variable-domain (hash-ref domains unassigned-variable))
|
|
|
|
(for ([value (in-list (unassigned-variable-domain))])
|
|
|
|
(for ([value (in-list (unassigned-variable-domain))])
|
|
|
|
(hash-set! assignments unassigned-variable value)
|
|
|
|
(hash-set! assignments unassigned-variable value)
|
|
|
|
(when (not (is-true? variables domains assignments))
|
|
|
|
(when (not (broken? variables domains assignments))
|
|
|
|
(send unassigned-variable-domain hide-value value)))
|
|
|
|
(send unassigned-variable-domain hide-value value)))
|
|
|
|
(hash-remove! assignments unassigned-variable)
|
|
|
|
(hash-remove! assignments unassigned-variable)
|
|
|
|
(not (null? unassigned-variable-domain))] ; if domain had no remaining values, the constraint will be impossible to meet, so return #f
|
|
|
|
(not (null? unassigned-variable-domain))] ; if domain had no remaining values, the constraint will be impossible to meet, so return #f
|
|
|
|
@ -69,7 +69,7 @@
|
|
|
|
|
|
|
|
|
|
|
|
(inherit forward-check)
|
|
|
|
(inherit forward-check)
|
|
|
|
|
|
|
|
|
|
|
|
(define/override (is-true? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
|
|
|
|
(define/override (broken? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
|
|
|
|
(define parms (map (λ(v) (hash-ref assignments v _unassigned)) variables))
|
|
|
|
(define parms (map (λ(v) (hash-ref assignments v _unassigned)) variables))
|
|
|
|
(define missing (length (filter (λ(p) (equal? p _unassigned)) parms)))
|
|
|
|
(define missing (length (filter (λ(p) (equal? p _unassigned)) parms)))
|
|
|
|
(if (> missing 0)
|
|
|
|
(if (> missing 0)
|
|
|
|
@ -85,7 +85,7 @@
|
|
|
|
(class constraint%
|
|
|
|
(class constraint%
|
|
|
|
(super-new)
|
|
|
|
(super-new)
|
|
|
|
|
|
|
|
|
|
|
|
(define/override (is-true? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
|
|
|
|
(define/override (broken? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
|
|
|
|
(define-values (assigned-vars unassigned-vars)
|
|
|
|
(define-values (assigned-vars unassigned-vars)
|
|
|
|
(partition (λ(var) (hash-has-key? assignments var)) variables))
|
|
|
|
(partition (λ(var) (hash-has-key? assignments var)) variables))
|
|
|
|
(define assigned-values (map (λ(var) (hash-ref assignments var)) assigned-vars))
|
|
|
|
(define assigned-values (map (λ(var) (hash-ref assignments var)) assigned-vars))
|
|
|
|
@ -106,7 +106,7 @@
|
|
|
|
(class constraint%
|
|
|
|
(class constraint%
|
|
|
|
(super-new)
|
|
|
|
(super-new)
|
|
|
|
|
|
|
|
|
|
|
|
(define/override (is-true? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
|
|
|
|
(define/override (broken? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
|
|
|
|
(define singlevalue _unassigned)
|
|
|
|
(define singlevalue _unassigned)
|
|
|
|
(define value #f)
|
|
|
|
(define value #f)
|
|
|
|
(define domain #f)
|
|
|
|
(define domain #f)
|
|
|
|
|
