From 686514dfb20f41877bbcd46f14d159eec1c267b7 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Wed, 10 Oct 2018 17:48:21 -0700
Subject: [PATCH] still

---
 csp/csp.rkt  | 18 ++++++++++++------
 csp/test.rkt | 25 +++++++++++++++++++++++--
 2 files changed, 35 insertions(+), 8 deletions(-)

diff --git a/csp/csp.rkt b/csp/csp.rkt
index 17976f9b..ff9d25cc 100644
--- a/csp/csp.rkt
+++ b/csp/csp.rkt
@@ -45,6 +45,9 @@
     (raise-argument-error 'add-var! "var that doesn't exist" name))
   (set-$csp-vars! csp (cons ($var name vals) ($csp-vars csp))))
 
+(define (unique-varnames? xs)
+  (and (andmap $var-name? xs) (not (check-duplicates xs eq?))))
+
 (define/contract (add-constraint! csp proc . var-names)
   (($csp? procedure?) #:rest (listof $var-name?) . ->* . void?)
   (for ([name (in-list var-names)])
@@ -73,7 +76,7 @@
   (when (no-solutions? new-csp) (raise ($csp-inconsistent)))
   new-csp)
 
-(define/contract (make-node-consistent csp)
+(define/contract (make-nodes-consistent csp)
   ($csp? . -> . $csp?)
   (for/fold ([csp csp])
             ([constraint (in-list ($csp-constraints csp))]
@@ -134,7 +137,7 @@
                             ;; revision reduced the domain, so supplement the list of arcs
                             (remove-duplicates (append (all-arcs . terminating-at . name) other-arcs))))))
 
-(define/contract (make-arc-consistent csp)
+(define/contract (make-arcs-consistent csp)
   ($csp? . -> . $csp?)
   ;; csp is arc-consistent if every pair of variables (x y)
   ;; has values in their domain that satisfy every binary constraint
@@ -200,11 +203,14 @@
            (backtrack (infer (assign-val csp name val))))))]
     [else (raise ($csp-inconsistent))]))
      
-(define/contract (solve csp)
-  ($csp? . -> . any/c)
-  (backtrack (make-arc-consistent (make-node-consistent csp))))
+(define/contract (solve csp [finish-proc values])
+  (($csp?) (procedure?) . ->* . any/c)
+  (finish-proc (backtrack (make-arcs-consistent (make-nodes-consistent csp)))))
+
+(define ($csp-ref csp name)
+  (car ($csp-vals csp name)))
 
 (define/contract (alldiff . xs)
   (() #:rest (listof any/c) . ->* . boolean?)
-  (for*/and ([comb (in-combinations xs 2)])
+  (for/and ([comb (in-combinations xs 2)])
    (not (apply equal? comb)))) 
diff --git a/csp/test.rkt b/csp/test.rkt
index c96495ff..af5d9171 100644
--- a/csp/test.rkt
+++ b/csp/test.rkt
@@ -1,4 +1,4 @@
-#lang racket
+#lang at-exp racket
 (require "csp.rkt" rackunit)
 
 (let ([demo (new-csp)])
@@ -23,6 +23,8 @@
   (add-constraint! demo three-or-less 'o)
   (check-equal? (solve demo) ($csp (list ($var 'o '(2)) ($var 'w '(1)) ($var 't '(0))) '())))
 
+
+;; TWO + TWO = FOUR
 (define ttf (new-csp))
 (define digs (range 10))
 (add-var! ttf 't digs)
@@ -44,4 +46,23 @@
 (add-constraint! ttf positive? 'f)
 (add-constraint! ttf = 'f 'c1000)
 
-(check-equal? (solve ttf) ($csp (list ($var 'c1000 '(1)) ($var 'c100 '(0)) ($var 'c10 '(0)) ($var 'r '(8)) ($var 'u '(6)) ($var 'f '(1)) ($var 'o '(4)) ($var 'w '(3)) ($var 't '(7))) '()))
+
+(define ttf-solution (solve ttf)) 
+(check-equal? ttf-solution
+              ($csp
+               (list
+                ($var 'c1000 '(1))
+                ($var 'c100 '(0))
+                ($var 'c10 '(0))
+                ($var 'r '(8))
+                ($var 'u '(6))
+                ($var 'f '(1))
+                ($var 'o '(4))
+                ($var 'w '(3))
+                ($var 't '(7)))
+               '()))
+
+(define (ttf-print csp)
+  (format "~a~a~a + ~a~a~a = ~a~a~a~a" ($csp-ref csp 't) ($csp-ref csp 'w) ($csp-ref csp 'o) ($csp-ref csp 't) ($csp-ref csp 'w) ($csp-ref csp 'o) ($csp-ref csp 'f) ($csp-ref csp 'o) ($csp-ref csp 'u) ($csp-ref csp 'r)))
+
+(check-equal? (solve ttf-solution ttf-print) "734 + 734 = 1468")