cleanup

csp/constraint.rkt

@@ -1,12 +1,12 @@
 #lang racket/base
-(require racket/class sugar/container sugar/list sugar/debug racket/list "helper.rkt" "variable.rkt")
+(require racket/class racket/bool sugar/container sugar/list sugar/debug racket/list "helper.rkt" "variable.rkt")
 (provide (all-defined-out))
 
 (define constraint%
   (class object% 
     (super-new)
     
-    (define/public (broken? variables domains assignments [forward-check? #f])
+    (define/public (is-true? variables domains assignments [forward-check? #f])
       ;; Perform the constraint checking
       
       ;;  If the forwardcheck parameter is not false, besides telling if
@@ -31,7 +31,7 @@
         (set-field! _list domain
                     (for/fold ([domain-values (domain)]) 
                       ([value (in-list (domain))] 
-                       #:unless (broken? variables domains (make-hash (list (cons variable value)))))
+                       #:unless (is-true? variables domains (make-hash (list (cons variable value)))))
                       (remove value domain-values)))        
         (set! constraints (remove (list this variables) constraints))
         (hash-update! vconstraints variable (λ(val) (remove (list this variables) val)))))
@@ -50,7 +50,7 @@
          (define unassigned-variable-domain (hash-ref domains unassigned-variable))
          (for ([value (in-list (unassigned-variable-domain))])
            (hash-set! assignments unassigned-variable value)
-           (when (not (broken? variables domains assignments))
+           (unless (is-true? variables domains assignments)
              (send unassigned-variable-domain hide-value value)))
          (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
@@ -69,7 +69,7 @@
     
     (inherit forward-check)
     
-    (define/override (broken? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
+    (define/override (is-true? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
       (define parms (map (λ(v) (hash-ref assignments v _unassigned)) variables))
       (define missing (length (filter (λ(p) (equal? p _unassigned)) parms)))
       (if (> missing 0)
@@ -85,7 +85,7 @@
   (class constraint% 
     (super-new)
     
-    (define/override (broken? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
+    (define/override (is-true? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
       (define-values (assigned-vars unassigned-vars) 
         (partition (λ(var) (hash-has-key? assignments var)) variables))      
       (define assigned-values (map (λ(var) (hash-ref assignments var)) assigned-vars))
@@ -106,7 +106,7 @@
   (class constraint% 
     (super-new)
     
-    (define/override (broken? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
+    (define/override (is-true? variables domains assignments [forward-check? #f] [_unassigned Unassigned])
       (define singlevalue _unassigned)
       (define value #f)
       (define domain #f)
@@ -118,7 +118,7 @@
                           _unassigned))
           (cond
             [(equal? singlevalue _unassigned) (set! singlevalue value)]
-            [(and (not (equal? value _unassigned)) (not (equal? value singlevalue)))
+            [(nor (equal? value _unassigned) (equal? value singlevalue))
              (set! return-value #f)
              (return-k)]))
         (when (and forward-check? (not (equal? singlevalue _unassigned)))

csp/helper.rkt

@@ -3,6 +3,14 @@
 (provide (all-defined-out))
 (require rackunit)
 
+(define-syntax-rule (forever expr ...)
+  (for ([i (in-naturals)])
+    expr ...))
+
+(define-syntax-rule (forever/or expr ...)
+  (for/or ([i (in-naturals)])
+    expr ...))
+
 (define-syntax-rule (for-each-send proc objects)
   (for-each (λ(o) (send o proc)) objects))
 

csp/solver.rkt

@@ -30,10 +30,10 @@
     
     (define/override (get-solution-iter domains constraints vconstraints)
       (define sorted-variables 
-        (map last (sort (for/list ([(variable domain) (in-hash domains)])
-                          (list (- (length (hash-ref vconstraints variable))) ; first two elements used for sorting 
-                                (length (domain))
-                                variable)) list-comparator)))
+        (map third (sort (map (λ(var)
+                                (list (- (length (hash-ref vconstraints var))) ; first two elements used for sorting 
+                                      (length ((hash-ref domains var)))
+                                      var)) (hash-keys domains)) list-comparator)))
       ;; state-retention variables
       (define possible-solution (make-hash))
       (define variable-queue null)
@@ -61,34 +61,34 @@
       
       (let/ec exit-k
         ;; mix the degree and minimum-remaining-values (MRV) heuristics
-        (let main-loop ()
-          (unless (get-next-unassigned-variable)
-            (yield (hash-copy possible-solution)) ; if there are no unassigned variables, solution is done. 
-            (if (null? variable-queue) ; if queue isn't empty, return to previous variable, otherwise all done.
-                (exit-k)
-                (set!-previous-variable)))
-          
-          (let value-checking-loop () ; we have a variable. Do we have any values left?
-            (when (null? values) ; no, so try going back to last variable and getting some values
-              (for/or ([i (in-naturals)])
-                (when (null? variable-queue) (exit-k)) ; no variables left, so solver is done
-                (hash-remove! possible-solution variable)
-                (set!-previous-variable)
-                (not (null? values))))        
-            
-            ;; Got a value. Check it.
-            (hash-set! possible-solution variable (car-pop! values))
-            (for-each-send push-state pushdomains)
-            (when (for/or ([cvpair (in-list (hash-ref vconstraints variable))])
-                    (match-define (list constraint variables) cvpair)
-                    (not (send constraint broken? variables domains possible-solution pushdomains)))
-              ;; constraint failed, so try again
-              (for-each-send pop-state pushdomains) 
-              (value-checking-loop)))
-          
-          ;; Push state before looking for next variable.
-          (set! variable-queue (cons (vvp variable values pushdomains) variable-queue))
-          (main-loop))
+        (forever
+         (unless (get-next-unassigned-variable)
+           (yield (hash-copy possible-solution)) ; if there are no unassigned variables, solution is complete.
+           (if (null? variable-queue) ; then, if queue is empty ...
+               (exit-k) ; all done, no other solutions possible.
+               (set!-previous-variable))) ; or queue is not empty, so return to previous variable
+         
+         (let value-checking-loop () ; we have a variable. Do we have any values left?
+           (when (null? values) ; no, so try going back to last variable and getting some values
+             (forever/or
+              (when (null? variable-queue) (exit-k)) ; no variables left, so solver is done
+              (hash-remove! possible-solution variable)
+              (set!-previous-variable)
+              (not (null? values))))        
+           
+           ;; Got a value. Check it.
+           (hash-set! possible-solution variable (car-pop! values))
+           (for-each-send push-state pushdomains)
+           (unless (for/and ([constraint+variables (in-list (hash-ref vconstraints variable))])
+                     (let ([constraint (car constraint+variables)]
+                           [variables (cadr constraint+variables)])
+                       (send constraint is-true? variables domains possible-solution pushdomains)))
+             ;; constraint failed, so try again
+             (for-each-send pop-state pushdomains) 
+             (value-checking-loop)))
+         
+         ;; Push state before looking for next variable.
+         (set! variable-queue (cons (vvp variable values pushdomains) variable-queue)))
         (error 'get-solution-iter "impossible to reach this"))      
       (void))