nits

csp/csp/hacs.rkt

@@ -73,19 +73,23 @@
   (() ((listof var?) (listof constraint?)) . ->* . csp?)
   (csp vars consts))
 
+(define/contract (make-var name [vals null])
+  ((name?) ((listof any/c)) . ->* . var?)
+  (var name vals))
+
 (define/contract (add-vars! prob names-or-procedure [vals-or-procedure empty])
   ((csp? (or/c (listof name?) procedure?)) ((or/c (listof any/c) procedure?)) . ->* . void?)
   (for/fold ([vrs (vars prob)]
-             #:result (set-csp-vars! prob vrs))
+             #:result (set-csp-vars! prob (reverse vrs)))
             ([name (in-list (match names-or-procedure
                               [(? procedure? proc) (proc)]
                               [names names]))])
     (when (memq name (map var-name vrs))
       (raise-argument-error 'add-vars! "var that doesn't already exist" name))
-    (append vrs (list (var name
+    (cons (make-var name
-                           (if (procedure? vals-or-procedure)
+                    (match vals-or-procedure
-                               (vals-or-procedure)
+                      [(? procedure? proc) (proc)]
-                               vals-or-procedure))))))
+                      [vals vals])) vrs)))
 
 (define/contract (add-var! prob name [vals-or-procedure empty])
   ((csp? name?) ((or/c (listof any/c) procedure?)) . ->* . void?)
@@ -206,33 +210,34 @@
 
 (define/contract (assign-val prob name val)
   (csp? name? any/c . -> . csp?)
-  (when-debug (set! nassns (add1 nassns)))
+  (begin0
     (make-csp
      (for/list ([vr (in-vars prob)])
        (if (eq? name (var-name vr))
            (assigned-var name (list val))
            vr))
-   (constraints prob)))
+     (constraints prob))
+    (when-debug (set! nassns (add1 nassns)))))
 
-(define/contract (assigned-vars prob)
+(define/contract (assigned-vars prob [invert? #f])
-  (csp? . -> . (listof var?))
+  ((csp?) (any/c) . ->* . (listof var?))
-  (filter assigned-var? (vars prob)))
+  ((if invert? filter-not filter) assigned-var? (vars prob)))
 
 (define/contract (unassigned-vars prob)
   (csp? . -> . (listof var?))
-  (filter-not assigned-var? (vars prob)))
+  (assigned-vars prob 'invert))
 
 (define/contract (first-unassigned-variable csp)
   (csp? . -> . (or/c #false (and/c var? (not/c assigned-var?))))
   (match (unassigned-vars csp)
-    [(? empty?) #false]
+    [(== empty) #false]
     [xs (first xs)]))
 
 (define/contract (argmin* proc xs [max-style? #f])
   ((procedure? (listof any/c)) (any/c) . ->* . (listof any/c))
   ;; return all elements that have min value.
   (match xs
-    [(? empty?) xs]
+    [(== empty) xs]
     [(list x) xs]
     [xs
      (define vals (map proc xs))
@@ -250,13 +255,13 @@
 (define/contract (minimum-remaining-values prob)
   (csp? . -> . (or/c #false (and/c var? (not/c assigned-var?))))
   (match (unassigned-vars prob)
-    [(? empty?) #false]
+    [(== empty) #false]
     [uvars (random-pick (argmin* domain-length uvars))]))
 
 (define/contract (max-degree prob)
   (csp? . -> . (or/c #false (and/c var? (not/c assigned-var?))))
   (match (unassigned-vars prob)
-    [(? empty?) #false]
+    [(== empty) #false]
     [uvars (random-pick (argmax* (λ (var) (var-degree prob var)) uvars))]))
 
 (define mrv minimum-remaining-values)
@@ -279,7 +284,7 @@
 (define/contract (mrv-degree-hybrid prob)
   (csp? . -> . (or/c #f var?))
   (match (unassigned-vars prob)
-    [(? empty?) #false]
+    [(== empty) #false]
     [uvars
      (max-degree (make-csp (argmin* domain-length uvars) (constraints prob)))]))
   
@@ -326,7 +331,7 @@
      (cond
        [(assigned-var? vr) vr]
        [(eq? name (var-name vr))
-        (var name (match (filter satisfies-arc? (domain vr))
+        (make-var name (match (filter satisfies-arc? (domain vr))
                          [(? empty?) (backtrack!)]
                          [vals vals]))]
        [else vr]))
@@ -472,7 +477,7 @@
        (for/list ([vr (in-vars prob)])
          (match-define (var name vals) vr)
          (define name-constraints (filter (λ (const) (constraint-relates? const name)) unary-constraints))
-         (var name (for/list ([val (in-list vals)]
+         (make-var name (for/list ([val (in-list vals)]
                                    #:when (for/and ([const (in-list name-constraints)])
                                             ((constraint-proc const) val)))
                           val)))

csp/csp/sudoku-jm.rkt

@@ -1,4 +1,4 @@
-#lang racket/base
+#lang debug racket/base
 (require racket/match
          racket/list
          racket/set)
@@ -25,43 +25,18 @@
   (= (cell-y l) (cell-y r)))
 
 ;; a grid is a list of cells
-
-(define hrule "-----------")
-
 ;; board : string ... -> grid
 (define (board . ss)
-  (match-define
+  (for*/fold ([cells null]
-   (list r1 r2 r3 (== hrule)
+              #:result (reverse cells))
-         r4 r5 r6 (== hrule)
+             ([str (in-list ss)]
-         r7 r8 r9)
+              [c (in-port read-char (open-input-string str))]
-   ss)
+              #:unless (memv c '(#\- #\|)))
-  (define rs
+    (define-values (row col) (quotient/remainder (length cells) 9))
-    (list r1 r2 r3 r4 r5 r6 r7 r8 r9))
+    (cons (cell col row (cond
-  (flatten
+                          [(string->number (string c)) => seteq]
-   (for/list ([r (in-list rs)]
+                          [else anything])) cells)))
-              [y (in-naturals)])
-     (parse-row y r))))
 
-(define (parse-row y r)
-  (for/list ([c (in-string r)]
-             [i (in-naturals)])
-    (cond
-      [(or (= i 3) (= i 7))
-       (if (char=? c #\|)
-         empty
-         (error 'parse-row))]
-      [else
-       (define x
-         (cond [(< i 3) (- i 0)]
-               [(< i 7) (- i 1)]
-               [   else (- i 2)]))
-       (parse-cell y x c)])))
-
-(define (parse-cell y x c)
-  (cell x y
-        (if (char=? #\space c)
-          anything
-          (seteq (string->number (string c))))))
 
 (define (propagate-one top cs)
   (let/ec return
@@ -273,7 +248,7 @@
     (on-draw draw-draw-state)))
 
 ;; Wikipedia Example
-  (define b1
+(define b1
   (board
    "53 | 7 |   "
    "6  |195|   "
@@ -287,8 +262,8 @@
    "   |419|  5"
    "   | 8 | 79"))
 
-  ;; "Hard" example
+;; "Hard" example
-  (define b2
+(define b2
   (board
    " 7 | 2 |  5"
    "  9| 87|  3"
@@ -302,8 +277,8 @@
    "5  |21 |4  "
    "4  | 9 | 6 "))
 
-  ;; "Evil" example
+;; "Evil" example
-  (define b3
+(define b3
   (board
    "  8|   | 45"
    "   | 8 |9  "
@@ -317,12 +292,10 @@
    "  7| 6 |   "
    "65 |   |3  "))
 
-  #;(draw-state-i
+#;(draw-state-i
    (draw-it!
     (solve-it
      b2)))
-
-
 (require sugar/debug)
 (time-avg 10 (void (solve-it b1)))
 (time-avg 10 (void (solve-it b2)))