deshuffle

csp/hacs-test-workbench.rkt

@@ -4,12 +4,15 @@
 (current-inference forward-check)
 (current-select-variable mrv)
 (current-order-values shuffle)
-(current-shuffle #true)
+(current-random #true)
 
 ;; queens problem
 ;; place queens on chessboard so they do not intersect
+
+(define board-size 8)
+
   (define queens (make-csp))
-(define qs (for/list ([q 8]) (string->symbol (format "q~a" q))))
+  (define qs (for/list ([q board-size]) (string->symbol (format "q~a" q))))
   (define rows (range (length qs)))
   (add-vars! queens qs rows)
   (define (q-col q) (string->number (string-trim (symbol->string q) "q")))
@@ -23,6 +26,6 @@
                         (= qa-row qb-row))) ; same row?
                      (list qa qb)))
 
-#;(time-named (solve queens))
+(time-avg 10 (solve queens))
 (parameterize ([current-solver min-conflicts])
   (time-named (solve queens)))

csp/hacs-test.rkt

@@ -4,7 +4,7 @@
 (current-inference forward-check)
 (current-select-variable mrv-degree-hybrid)
 (current-order-values shuffle)
-(current-shuffle #true)
+(current-random #true)
 
 (check-equal? (first-unassigned-variable ($csp (list ($var 'a (range 3)) ($var 'b (range 3))) null))
               ($var 'a (range 3)))
@@ -278,7 +278,7 @@
   (apply map list (slice-at x 5)))
 
 (check-equal? (parameterize ([current-select-variable mrv]
-                             [current-shuffle #f])
+                             [current-random #f])
                 (finish (time-named (solve zebra))))
               '(((nationality-0 . norwegian) (color-0 . yellow) (drink-0 . water) (smoke-0 . kools) (pet-0 . foxes))
                 ((nationality-1 . ukrainian) (color-1 . blue) (drink-1 . tea) (smoke-1 . chesterfields) (pet-1 . horses))

csp/hacs.rkt

@@ -117,7 +117,7 @@
 (define current-order-values (make-parameter #f))
 (define current-inference (make-parameter #f))
 (define current-solver (make-parameter #f))
-(define current-shuffle (make-parameter #t))
+(define current-random (make-parameter #t))
 
 (define/contract (check-name-in-csp! caller csp name)
   (symbol? csp? name? . -> . void?)
@@ -214,7 +214,7 @@
   (csp? . -> . (or/c #false (and/c $var? (not/c assigned-var?))))
   (match (unassigned-vars csp)
     [(? empty?) #false]
-    [xs (argmin (λ (var) (length ($var-domain var))) (shuffle xs))]))
+    [xs (argmin (λ (var) (length ($var-domain var))) xs)]))
 
 (define mrv minimum-remaining-values)
 
@@ -252,7 +252,7 @@
         ;; use degree as tiebreaker for mrv
         (define max-degree-arg (argmax (λ (var) (var-degree csp var)) mrv-uvars))
         ;; use random tiebreaker for degree
-        (first (shuffle (filter (λ (var) (= (var-degree csp max-degree-arg) (var-degree csp var))) mrv-uvars)))])]))
+        (random-pick (filter (λ (var) (= (var-degree csp max-degree-arg) (var-degree csp var))) mrv-uvars))])]))
   
 (define first-domain-value values)
 
@@ -412,8 +412,10 @@
                         (loop csp)))
                     conflicts)]))))
 
+(define (random-pick xs)
+  (list-ref xs (random (length xs))))
 
-(define/contract (min-conflicts csp [max-steps 64])
+(define/contract (min-conflicts csp [max-steps 100])
   (($csp?) (integer?) . ->* . generator?)
   ;; Solve a CSP by stochastic hillclimbing on the number of conflicts.
   (generator ()
@@ -423,17 +425,16 @@
                  (for/fold ([csp csp0])
                                  ([var (in-vars csp0)])
                          (define name (var-name var))
-                   (assign-val csp name (first (shuffle ($csp-vals csp0 name))))))
+                         (assign-val csp name (random-pick ($csp-vals csp0 name)))))
                ;; Now repeatedly choose a random conflicted variable and change it
                (for/fold ([csp starting-assignment])
                          ([i (in-range max-steps)])
                  (match (conflicted-var-names csp)
-                   [(? empty?) (when (check-constraints csp) (yield csp)) (loop csp0)]
-                   [cvar-names
-                    (define cvar-name (first ((if (current-shuffle) shuffle values) cvar-names)))
-                    (define val (min-conflicts-value csp cvar-name ($csp-vals csp0 cvar-name)))
-                    (assign-val csp cvar-name val)]))
-               (loop csp0))))
+                   [(? empty?) (yield csp) (loop csp0)]
+                   [names
+                    (define name (random-pick names))
+                    (define val (min-conflicts-value csp name ($csp-vals csp0 name)))
+                    (assign-val csp name val)])))))
 
 (define/contract (conflicted-var-names csp)
   ($csp? . -> . (listof name?))
@@ -445,7 +446,11 @@
 (define/contract (min-conflicts-value csp name vals)
   ($csp? name? (listof any/c) . -> . any/c)
   ;; Return the value that will give var the least number of conflicts
-  (argmin (λ (val) (nconflicts csp name val)) (shuffle vals)))
+  (define vals-by-conflict (sort vals < #:key (λ (val) (nconflicts csp name val))
+                                 #:cache-keys? #true))
+  (for/first ([val (in-list vals-by-conflict)]
+              #:unless (equal? val (first ($csp-vals csp name))))
+    val))
 
 (define no-value-sig (gensym))