From 5b76a51d652163119f94aaa05db08cea16e241d2 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Fri, 19 Oct 2018 23:20:36 -0700
Subject: [PATCH] do it again

---
 csp/hacs-test-workbench.rkt | 116 +------------------------------
 csp/hacs-test.rkt           | 131 +++++++++++++++++++++++++++++++++++-
 csp/hacs.rkt                |  24 ++++---
 3 files changed, 146 insertions(+), 125 deletions(-)

diff --git a/csp/hacs-test-workbench.rkt b/csp/hacs-test-workbench.rkt
index d592c496..dad7dcf2 100644
--- a/csp/hacs-test-workbench.rkt
+++ b/csp/hacs-test-workbench.rkt
@@ -2,118 +2,6 @@
 (require sugar "hacs.rkt")
 
 (current-inference forward-check)
-(current-select-variable mrv-degree-hybrid)
+(current-select-variable mrv)
 (current-order-values shuffle)
-(current-shuffle #true)
-
-
-#|
-# There are no tricks, just pure logic, so good luck and don't give up. 
-# 
-# 1. In a street there are five houses, painted five different colours. 
-# 2. In each house lives a person of different nationality 
-# 3. These five homeowners each drink a different kind of beverage, smoke 
-# different brand of cigar and keep a different pet. 
-# 
-# THE QUESTION: WHO OWNS THE zebra? 
-# 
-# HINTS 
-# 
-# 1. The englishman lives in a red house. 
-# 2. The spaniard keeps dogs as pets. 
-# 5. The owner of the Green house drinks coffee. 
-# 3. The ukrainian drinks tea. 
-# 4. The Green house is on the left of the ivory house. 
-# 6. The person who smokes oldgold rears snails. 
-# 7. The owner of the Yellow house smokes kools. 
-# 8. The man living in the centre house drinks milk. 
-# 9. The Norwegian lives in the first house. 
-# 10. The man who smokes chesterfields lives next to the one who keeps foxes. 
-# 11. The man who keeps horses lives next to the man who smokes kools. 
-# 12. The man who smokes luckystrike drinks orangejuice. 
-# 13. The japanese smokes parliaments. 
-# 14. The Norwegian lives next to the blue house. 
-# 15. The man who smokes chesterfields has a neighbour who drinks water. 
-|#
-
-(define (sym . args) (string->symbol (apply format args)))
-
-(define zebra (make-csp))
-
-(define ns (map (curry sym "nationality-~a") (range 5)))
-(define cs (map (curry sym "color-~a") (range 5)))
-(define ds (map (curry sym "drink-~a") (range 5)))
-(define ss (map (curry sym "smoke-~a") (range 5)))
-(define ps (map (curry sym "pet-~a") (range 5)))
-
-(add-vars! zebra ns '(englishman spaniard ukrainian norwegian japanese))
-(add-vars! zebra cs '(red ivory green yellow blue))
-(add-vars! zebra ds '(tea coffee milk orange-juice water))
-(add-vars! zebra ss '(oldgold kools chesterfields luckystrike parliaments))
-(add-vars! zebra ps '(dogs snails foxes horses zebra))
-
-(for ([vars (list ns cs ds ss ps)])
-  (add-pairwise-constraint! zebra neq? vars))
-
-(define (paired-with lval left rval right)
-  (add-constraint! zebra (λ (left right) (or (not (eq? left lval)) (eq? rval right))) (list left right)))
-
-(define (paired-with* lval lefts rval rights)
-  (for ([left lefts][right rights])
-    (paired-with lval left rval right)))
-
-;# 1. The englishman lives in a red house. 
-('englishman ns . paired-with* . 'red cs)
-
-;# 2. The spaniard keeps dogs as pets. 
-('spaniard ns . paired-with* . 'dogs ps)
-
-;# 5. The owner of the Green house drinks coffee. 
-('green cs . paired-with* . 'coffee ds)
-
-;# 3. The ukrainian drinks tea.
-('ukrainian ns . paired-with* . 'tea ds)
-
-;# 4. The Green house is on the left of the ivory house.
-('green (drop-right cs 1) . paired-with* . 'ivory (drop cs 1))
-(add-constraint! zebra (curry neq? 'ivory) (list 'color-0))
-(add-constraint! zebra (curry neq? 'green) (list 'color-4))
-
-;# 6. The person who smokes oldgold rears snails.
-('oldgold ss . paired-with* . 'snails ps)
-
-;# 7. The owner of the Yellow house smokes kools.
-('yellow cs . paired-with* . 'kools ss)
-
-;# 8. The man living in the centre house drinks milk.
-(add-constraint! zebra (λ (d) (eq? d 'milk)) (list 'drink-2))
-
-;# 9. The Norwegian lives in the first house.
-(add-constraint! zebra (λ (x) (eq? x 'norwegian)) (list 'nationality-0))
-
-(define (next-to lval lefts rval rights)
-  (lval (drop-right lefts 1) . paired-with* . rval (drop rights 1))
-  (lval (drop lefts 1) . paired-with* . rval (drop-right rights 1)))
-
-;# 10. The man who smokes chesterfields lives next to the one who keeps foxes.
-('chesterfields ss . next-to . 'foxes ps)
-
-;# 11. The man who keeps horses lives next to the man who smokes kools.
-;('horses ps . next-to . 'kools ss)
-
-;# 12. The man who smokes luckystrike drinks orangejuice.
-('luckystrike ss . paired-with* . 'orange-juice ds)
-
-;# 13. The japanese smokes parliaments.
-('japanese ns . paired-with* . 'parliaments ss)
-
-;# 14. The Norwegian lives next to the blue house.
-;('norwegian ns . next-to . 'water ds)
-
-;# 15. The man who smokes chesterfields has a neighbour who drinks water. 
-;('chesterfields ss . next-to . 'water ds)
-
-(define (finish x)
-  (apply map list (slice-at x 5)))
-
-(map finish (list (time (solve zebra))))
\ No newline at end of file
+(current-shuffle #true)
\ No newline at end of file
diff --git a/csp/hacs-test.rkt b/csp/hacs-test.rkt
index 02c07af4..b13507b9 100644
--- a/csp/hacs-test.rkt
+++ b/csp/hacs-test.rkt
@@ -1,5 +1,5 @@
 #lang debug racket
-(require "hacs.rkt" rackunit)
+(require "hacs.rkt" rackunit sugar/list)
 
 (current-inference forward-check)
 (current-select-variable mrv-degree-hybrid)
@@ -155,4 +155,131 @@
                       (not (= qa-row qb-row)))) ; same row?
                    (list qa qb)))
 
-(check-equal? 92 (length (time (solve* queens))))
\ No newline at end of file
+(check-equal? 92 (length (time (solve* queens))))
+
+
+#|
+# There are no tricks, just pure logic, so good luck and don't give up. 
+# 
+# 1. In a street there are five houses, painted five different colours. 
+# 2. In each house lives a person of different nationality 
+# 3. These five homeowners each drink a different kind of beverage, smoke 
+# different brand of cigar and keep a different pet. 
+# 
+# THE QUESTION: WHO OWNS THE zebra? 
+# 
+# HINTS 
+# 
+# 1. The englishman lives in a red house. 
+# 2. The spaniard keeps dogs as pets. 
+# 5. The owner of the Green house drinks coffee. 
+# 3. The ukrainian drinks tea. 
+# 4. The Green house is on the left of the ivory house. 
+# 6. The person who smokes oldgold rears snails. 
+# 7. The owner of the Yellow house smokes kools. 
+# 8. The man living in the centre house drinks milk. 
+# 9. The Norwegian lives in the first house. 
+# 10. The man who smokes chesterfields lives next to the one who keeps foxes. 
+# 11. The man who keeps horses lives next to the man who smokes kools. 
+# 12. The man who smokes luckystrike drinks orangejuice. 
+# 13. The japanese smokes parliaments. 
+# 14. The Norwegian lives next to the blue house. 
+# 15. The man who smokes chesterfields has a neighbour who drinks water. 
+|#
+
+(define (sym . args) (string->symbol (apply format args)))
+
+(define zebra (make-csp))
+
+(define ns (map (curry sym "nationality-~a") (range 5)))
+(define cs (map (curry sym "color-~a") (range 5)))
+(define ds (map (curry sym "drink-~a") (range 5)))
+(define ss (map (curry sym "smoke-~a") (range 5)))
+(define ps (map (curry sym "pet-~a") (range 5)))
+
+(add-vars! zebra ns '(englishman spaniard ukrainian norwegian japanese))
+(add-vars! zebra cs '(red ivory green yellow blue))
+(add-vars! zebra ds '(tea coffee milk orange-juice water))
+(add-vars! zebra ss '(oldgold kools chesterfields luckystrike parliaments))
+(add-vars! zebra ps '(dogs snails foxes horses zebra))
+
+(for ([vars (list ns cs ds ss ps)])
+  (add-pairwise-constraint! zebra neq? vars))
+
+(define (paired-with lval left rval right)
+  (add-constraint! zebra (λ (left right) (or (not (eq? left lval)) (eq? rval right))) (list left right)))
+
+(define (paired-with* lval lefts rval rights)
+  (for ([left lefts][right rights])
+    (paired-with lval left rval right)))
+
+;# 1. The englishman lives in a red house. 
+('englishman ns . paired-with* . 'red cs)
+
+;# 2. The spaniard keeps dogs as pets. 
+('spaniard ns . paired-with* . 'dogs ps)
+
+;# 5. The owner of the Green house drinks coffee. 
+('green cs . paired-with* . 'coffee ds)
+
+;# 3. The ukrainian drinks tea.
+('ukrainian ns . paired-with* . 'tea ds)
+
+;# 4. The Green house is on the left of the ivory house.
+('green (drop-right cs 1) . paired-with* . 'ivory (drop cs 1))
+(add-constraint! zebra (curry neq? 'ivory) (list 'color-0))
+(add-constraint! zebra (curry neq? 'green) (list 'color-4))
+
+;# 6. The person who smokes oldgold rears snails.
+('oldgold ss . paired-with* . 'snails ps)
+
+;# 7. The owner of the Yellow house smokes kools.
+('yellow cs . paired-with* . 'kools ss)
+
+;# 8. The man living in the centre house drinks milk.
+(add-constraint! zebra (λ (d) (eq? d 'milk)) (list 'drink-2))
+
+;# 9. The Norwegian lives in the first house.
+(add-constraint! zebra (λ (x) (eq? x 'norwegian)) (list 'nationality-0))
+
+(define (next-to lval lefts rval rights)
+  (for ([righta (drop-right rights 2)]
+        [left (cdr lefts)]
+        [rightb (drop rights 2)])
+    (add-constraint! zebra (λ (left righta rightb)
+                             (or (not (eq? left lval)) (eq? righta rval) (eq? rval rightb)))
+                     (list left righta rightb)))
+  (for ([left (list (first lefts) (last lefts))]
+        [right (list (second rights) (fourth rights))])
+    (add-constraint! zebra (λ (left right) (or (not (eq? left lval)) (eq? rval right)))
+                     (list left right))))
+
+;# 10. The man who smokes chesterfields lives next to the one who keeps foxes.
+('chesterfields ss . next-to . 'foxes ps)
+
+;# 11. The man who keeps horses lives next to the man who smokes kools.
+('horses ps . next-to . 'kools ss)
+
+;# 12. The man who smokes luckystrike drinks orangejuice.
+('luckystrike ss . paired-with* . 'orange-juice ds)
+
+;# 13. The japanese smokes parliaments.
+('japanese ns . paired-with* . 'parliaments ss)
+
+;# 14. The Norwegian lives next to the blue house.
+('norwegian ns . next-to . 'blue cs)
+
+;# 15. The man who smokes chesterfields has a neighbour who drinks water. 
+('chesterfields ss . next-to . 'water ds)
+
+(define (finish x)
+  (apply map list (slice-at x 5)))
+
+(equal? (parameterize ([current-select-variable mrv]
+                       [current-shuffle #f])
+          (finish (time (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))
+  ((nationality-2 . englishman) (color-2 . red) (drink-2 . milk) (smoke-2 . oldgold) (pet-2 . snails))
+  ((nationality-3 . japanese) (color-3 . green) (drink-3 . coffee) (smoke-3 . parliaments) (pet-3 . zebra))
+  ((nationality-4 . spaniard) (color-4 . ivory) (drink-4 . orange-juice) (smoke-4 . luckystrike) (pet-4 . dogs))))
diff --git a/csp/hacs.rkt b/csp/hacs.rkt
index db0fa941..908fc7b5 100644
--- a/csp/hacs.rkt
+++ b/csp/hacs.rkt
@@ -111,18 +111,19 @@
             [(? number? val) (= val (length pattern))])
     (raise-argument-error 'reduce-arity (format "list of length ~a, same as procedure arity" (procedure-arity proc)) pattern))
   (define reduced-arity-name (string->symbol (format "reduced-arity-~a" (object-name proc))))
-  (define-values (id-names vals) (partition symbol? pattern))
+  (define-values (boxed-id-names vals) (partition box? pattern))
+  (define id-names (map unbox boxed-id-names))
   (define new-arity (length id-names))
   (procedure-rename
    (λ xs
-     (unless (= (length xs) new-arity)
+     (unless (=  (length xs) new-arity)
        (apply raise-arity-error reduced-arity-name new-arity xs))
      (apply proc (for/fold ([acc empty]
                             [xs xs]
                             [vals vals]
                             #:result (reverse acc))
                            ([pat-item (in-list pattern)])
-                   (if (symbol? pat-item)
+                   (if (box? pat-item)
                        (values (cons (car xs) acc) (cdr xs) vals)
                        (values (cons (car vals) acc) xs (cdr vals))))))
    reduced-arity-name))
@@ -139,11 +140,12 @@
                     (partially-assigned? constraint))
                (match-define ($constraint cnames proc) constraint)
                ($constraint (filter-not assigned-name? cnames)
-                            ;; pattern is mix of values and symbols (indicating variables to persist)
+                            ;; pattern is mix of values and boxed symbols (indicating variables to persist)
+                            ;; use boxes here as cheap way to distinguish id symbols from value symbols
                             (let ([reduce-arity-pattern (for/list ([cname (in-list cnames)])
                                                           (if (assigned-name? cname)
                                                               (first ($csp-vals csp cname))
-                                                              cname))])
+                                                              (box cname)))])
                               (reduce-arity proc reduce-arity-pattern)))]
               [else constraint])))))
 
@@ -171,9 +173,11 @@
 
 (define/contract (argmin-random-tie proc xs)
   (procedure? (non-empty-listof any/c) . -> . any/c)
-  (define ordered-xs (sort xs < #:key proc))
-  (first ((if (current-shuffle) shuffle values)
-          (takef ordered-xs (λ (x) (= (proc (car ordered-xs)) (proc x)))))))
+  (let* ([xs (sort xs < #:key proc)]
+         [xs (takef xs (λ (x) (= (proc (car xs)) (proc x))))]
+         ;; don't shuffle short lists, not worth it
+         [xs ((if (current-shuffle) shuffle values) xs)])
+    (first xs)))
 
 (define/contract (minimum-remaining-values csp)
   ($csp? . -> . (or/c #false (and/c $var? (not/c $avar?))))
@@ -310,7 +314,7 @@
 
 (define/contract (make-nodes-consistent csp)
   ($csp? . -> . $csp?)
-  ;; todo: why does this function make searches so much slower?
+  ;; todo: why does this function slow down searches?
   ($csp
    (for/list ([var (in-list ($csp-vars csp))])
      (match-define ($var name vals) var)
@@ -353,6 +357,8 @@
                         (loop csp)))
                     conflicts)]))))
 
+;; todo: min-conflicts solver
+
 (define/contract ($csp-assocs csp)
   ($csp? . -> . (listof (cons/c $var-name? any/c)))
   (for/list ([var (in-list ($csp-vars csp))])