fixup

csp/csp/hacs-test-sudoku.rkt

@@ -97,23 +97,27 @@
 (current-random #true)
 (current-node-consistency #t)
 (current-arity-reduction #t)
-#;(time-avg 10 (solve b1 #:finish-proc print-grid))
-#;(time-avg 10 (solve b2 #:finish-proc print-grid))
-#;(time-avg 10 (solve b3 #:finish-proc print-grid))
+(time-avg 10 (void (solve b1)))
+(time-avg 10 (void (solve b2)))
+(time-avg 10 (void (solve b3)))
+
+
+(define (euler-value sol)
+  (match sol
+    [(list (cons (== 'c0) h) (cons (== 'c1) t) (cons (== 'c2) d) _ ...) 
+     (+ (* 100 h) (* 10 t) d)]))
+
+
+(require rackunit)
+(check-equal? (euler-value (solve b1)) 534)
+(check-equal? (euler-value (solve b2)) 378)
+(check-equal? (euler-value (solve b3)) 938)
 
 ;; https://projecteuler.net/problem=96
-;; todo: parsing of these is wrong
-(define bstrs
+;; answer 24702
+(define (do-euler)
+  (define bstrs
     (for/list ([puz (in-slice 10 (string-split (port->string (open-input-file "euler-sudoku-grids.txt")) "\n"))])
       (map (λ (str) (string-replace str "0" " ")) (cdr puz))))
-
-(car bstrs)
-(define bboard (apply board (car bstrs)))
-(solve bboard #:finish-proc print-grid)
-
-#;(for/fold ([sum 0])
-          ([(bstr idx) (in-indexed bstrs)])    
-  (define sol (solve (apply board bstr)))
-  (+ sum #R (+ (* 100 (cdr (assq 'c0 sol)))
-            (* 10 (cdr (assq 'c1 sol)))
-            (* 1 (cdr (assq 'c2 sol))))))
+  (for/sum ([bstr bstrs])
+    (euler-value (solve (apply board bstr)))))

csp/csp/hacs.rkt

@@ -474,16 +474,6 @@
              [val (in-list (map cdr assocs))])
      (equal? x val))))
 
-(define (history->constraint hst)
-  (constraint (map car hst) (make-hist-proc hst)))
-
-(define/contract (assign-singletons prob)
-  (csp? . -> . csp?)
-  (for/fold ([prob prob])
-            ([vr (in-vars prob)]
-             #:when (singleton-var? vr))
-    (assign-val prob (var-name vr) (first (var-domain vr)))))
-
 (define/contract (backtracking-solver
                   prob
                   #:select-variable [select-unassigned-variable
@@ -493,10 +483,8 @@
   ((csp?) (#:select-variable procedure? #:order-values procedure? #:inference procedure?) . ->* . generator?)
   (generator ()
              (define reduce-arity-proc (if (current-arity-reduction) reduce-constraint-arity values))
-             (define learned-constraints null)
              (define learning? (current-learning))
-             (let* ([prob ((if (current-node-consistency) make-nodes-consistent values) prob)]
-                    [prob (assign-singletons prob)])
+             (let* ([prob ((if (current-node-consistency) make-nodes-consistent values) prob)])
                (let loop ([prob prob])
                  (match (select-unassigned-variable prob)
                    [#false (yield prob)]
@@ -512,23 +500,11 @@
                       (with-handlers ([wants-backtrack?
                                        (λ (bt)
                                          (define bths (backtrack-histories bt))
-                                         (when learning?
-                                           (set! learned-constraints (append
-                                                                      (map history->constraint (filter (λ (bth) (<= 2 (length bth) 4)) bths))
-                                                                      learned-constraints)))
                                          (append conflicts (remq name (remove-duplicates
                                                                        (for*/list ([bth bths]
                                                                                    [rec bth])
                                                                          (car rec)) eq?))))])
                         (let* ([prob (assign-val prob name val)]
-                               [prob (if learning?
-                                         (and (for ([lc learned-constraints]
-                                                    #:when (for/and ([cname (constraint-names lc)])
-                                                                    (memq cname (map var-name (filter assigned-var? (vars prob))))))
-                                                   (unless (lc prob)
-                                                     (println 'boing)
-                                                     (backtrack!))) prob)
-                                         prob)]
                                ;; reduce constraints before inference,
                                ;; to create more forward-checkable (binary) constraints
                                [prob (reduce-arity-proc prob)]

csp/csp/sudoku-jm.rkt

@@ -272,8 +272,7 @@
             (on-tick move-right 1/8)
             (on-draw draw-draw-state)))
 
-(module+ main
-  ;; Wikipedia Example
+;; Wikipedia Example
   (define b1
     (board
      "53 | 7 |   "
@@ -318,7 +317,13 @@
      "  7| 6 |   "
      "65 |   |3  "))
 
-  (draw-state-i
+  #;(draw-state-i
    (draw-it!
     (solve-it
-     b2))))
+     b2)))
+
+
+(require sugar/debug)
+(time-avg 10 (void (solve-it b1)))
+(time-avg 10 (void (solve-it b2)))
+(time-avg 10 (void (solve-it b3)))